Страница 1 из 1
Сводная таблица
Добавлено: 12 мар 2013, 04:35
Romaska
Добрый день! Требуется помощь в написании макроса по переносу данных из нескольких таблиц в сводную!
Есть таблица1 (сводная)
каждый отдел (их 42)заполняет данные в таблице (таблица аналогична таблице1)
Необходимо из 42 файлов которые прислали отделы свести данные в таблицу1
Re: Сводная таблица
Добавлено: 16 мар 2013, 14:27
pashulka
Romaska, Небольшие уточнения :
1) Папка с исходными файлами всегда одна и та же или она может меняться и её нужно каждый раз выбирать с помощь диалогового окна ?
2) В этой папке могут находиться другие файлы .xls ?
3) Может ли быть так, что один(или более) отдел не пришлют свои данные ? и если да, то как быть в таком случае - не выполнять сведение данных, поставить на месте отсутствующих отделов 0 или -
Re: Сводная таблица
Добавлено: 17 мар 2013, 16:26
pashulka
На всякий случай выкладываю макрос, который теоретически может помочь в сведении отделов в одну таблицу.
Предполагается, что :
- на момент выполнения макроса, рабочая книга, содержащая сводная таблицу, открыта и более того, активна.
- все файлы источники-отделы, находятся в той же папке, что и сводная таблицы, однако, открывать их
не нужно.
- все таблицы располагаются в рабочем листе с именем "Лист1"
Код: Выделить всё
Private Sub Test2()
Dim iPath$, iFileName$, iDepartment$, iFormula$
Dim iSource As Range, iCell As Range ', iColumn%
iPath = ActiveWorkbook.Path & "\"
iFileName = Dir(iPath & "отдел*.xlsx")
With ActiveWorkbook.Worksheets("Лист1")
Set iSource = .Range(.Cells(7, 2), .Cells(.Rows.Count, 2).End(xlUp))
'имеет смысл использовать, если количество отделов может увеличиться
'иначе, можно обойтись без инструкции With и прочего, т.е., например
'Set iSource = ActiveWorkbook.Worksheets("Лист1").[B7:B50]
End With
'Application.ScreenUpdating = False
Do Until iFileName = ""
iDepartment = Mid(iFileName, 1, Len(iFileName) - 5)
Set iCell = iSource.Find(iDepartment, , xlValues, xlWhole)
If Not iCell Is Nothing Then
With iCell.Offset(, 1).Resize(, 17)
iFormula = "='" & iPath & "[" & iFileName & "]" & _
"Лист1'!" & .Item(1).Address(True, False) 'можно и без .Item(1)
.Formula = iFormula: .Value = .Value
End With
End If
iFileName = Dir
Loop
iSource.Offset(, 6).Formula = "=C7-G7"
'Application.ScreenUpdating = True
End Sub