Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Автозаполнить таблицу: продублировать список кассиров
 
Всем привет, нужен совет\помощь, суть следующая:
Существует таблица с репертуаром (дата и название спектакля) , а так же таблица с именами кассиров.
Необходимо заполнить 3-ю таблицу таким образом (см пример),что бы список всех кассиров продублировало по каждому числу\спектаклю.
Желательно пропуская выходной и с возможностью добавления кассира.

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

Заранее благодарю.
С уважением, Кирилл Владимирович
 
вариант на массивах (см файл) - нажать стрелку для запуска макроса
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 - 3 Май 2015 08:47:59
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
Зря что ли старался...
 
путём нехитрых, но и не кратких, манипуляций - поэкспериментировала с Умной Таблицей:
(по коду вместо "Лист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 - 3 Май 2015 14:56:01
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
Страницы: 1
Читают тему (гостей: 1)