Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Автозаполнить таблицу: продублировать список кассиров
 
#1
03.05.2015 01:39:09
Всем привет, нужен совет\помощь, суть следующая:
Существует таблица с репертуаром (дата и название спектакля) , а так же таблица с именами кассиров.
Необходимо заполнить 3-ю таблицу таким образом (см пример),что бы список всех кассиров продублировало по каждому числу\спектаклю.
Желательно пропуская выходной и с возможностью добавления кассира.

ЗЫ: сейчас это проставляется в ручную что приводит к потере времени и возникновению ошибок :(

Заранее благодарю.
С уважением, Кирилл Владимирович
 
 
 
#2
03.05.2015 08:24:53
вариант на массивах (см файл) - нажать стрелку для запуска макроса
p.s.Умной таблицей результат не оформляла - делается в 3 нажатия стандартными средствами xl:
из ячейки [g2] - CTRL+SHIFT+стрелка вниз и вправо --выбрать диапазон таблицы и Вставка-Таблица-С заголовками...
P.P.S
а) кассира можно добавлять в Лист-источник начальных массивов
б) чтобы пропускать выходной - дополните код условием If, зайдя в редактор через "alt+F8 - изменить"
Код
        If CStr(a(i, 2)) <> "Выходной" Then
            arr(k, 1) = a(i, 1): arr(k, 2) = a(i, 2): arr(k, 3) = b(j, 1)
            k = k + 1
        End If
Изменено: JeyCi - 03.05.2015 08:47:59
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
#3
03.05.2015 09:24:53
Зря что ли старался...
 
 
 
#4
03.05.2015 14:27:33
путём нехитрых, но и не кратких, манипуляций - поэкспериментировала с Умной Таблицей:
(по коду вместо "Лист1" указать свой лист для выгрузки или создать в книге "Лист1" до запуска кода)
Код
Option Base 1

Sub justT()
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Конст.")
'формируем 2 массива из исходных данных
a = .Range("a2:b" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
b = .Range("d2:d" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value
End With

'формируем итоговый массив
ReDim arr(1 To UBound(a, 1) * UBound(b, 1), 1 To 3): k = 1    
For i = 1 To UBound(a, 1)
        For j = 1 To UBound(b, 1)
        If CStr(a(i, 2)) <> "Выходной" Then
            arr(k, 1) = a(i, 1): arr(k, 2) = a(i, 2): arr(k, 3) = b(j, 1)
            k = k + 1
        End If
        Next
 Next

'удаляем Таблицу, если уже имеется на Лист1
If ThisWorkbook.Sheets("Лист1").ListObjects.Count <> 0 Then ThisWorkbook.Sheets("Лист1").ListObjects(1).Delete   

'создаём новую таблицу на Лист1
With ThisWorkbook.Sheets("Лист1")
    .ListObjects.Add(xlSrcRange, .Range("$C$3"), , xlYes).Name = "Table1"   'Таблицу в ячейку $C$3
    .ListObjects("Table1").HeaderRowRange.Resize(1, 3).Value = Array("Число:", "Спектакль:", "Кассир:") 'шапка
    .ListObjects("Table1").ListColumns(1).Range.Resize(UBound(arr, 1)).NumberFormat = "DD.MM.YYYY"   'формат дата 1-го столбца
    .Range("Table1").Resize(UBound(arr, 1), 3).Value = arr  'итоговый массив
    .ListObjects("Table1").DataBodyRange.Columns.AutoFit  'автоподбор ширины

       'чтобы удалить лишние пустые строки, наполнившие массив на "Выходные"
        'Loop Through Every Row in Table
        'http://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables
    For x = 1 To .ListObjects("Table1").Range.Rows.Count
    On Error GoTo en
        If .ListObjects("Table1").DataBodyRange(x, 3).Value = "" Then .ListObjects("Table1").ListRows(x).Delete: x = x - 1
    Next x
End With

en:     [a1].Activate

Application.ScreenUpdating = True
End Sub
Изменено: JeyCi - 03.05.2015 14:56:01
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
Страницы: 1
Наверх