Как скопировать и вставить данные в n новых книг на основе двух фильтров с помощью VBA?
Моя цель — скопировать и вставить данные из 1 главной книги в n отдельных книг.
Пользователь должен иметь возможность выбрать «Рабочий стол» в «Мастере», что затем инициирует создание X рабочих книг для каждого человека на этом столе. (каждому получателю не разрешено видеть данные других, поэтому данные по каждому рабочему столу должны быть разделены).
Фильтр должен работать по двум критериям:
- Первый критерий – «Письменный стол». Есть 3 варианта (стол 1, стол 2, стол 3).
- Второй критерий — это люди, закрепленные за каждым столом. У меня есть таблица сопоставления для каждого человека на столе на одном из основных листов.
До сих пор мне удалось создать только книгу, в которой показаны данные стола, но мне нужно разделить эти данные для каждого человека:
Option Explicit
Sub copy_data()
Dim count_col As Long
Dim count_row As Long
Dim RelationSheet As Worksheet
Dim AccountSheet As Worksheet
Dim InstructionSheet As Worksheet
Dim wb As Workbook, sht As Worksheet
Dim desk As String
Dim START_CELL As String
Set InstructionSheet = Sheet2
Set RelationSheet = Sheet1
Set AccountSheet = Sheet3
desk = InstructionSheet.Cells(14, 3).Text
START_CELL = "B5"
Set wb = Workbooks.Add
Set sht = ActiveSheet
sht.Name = "RELATION LEVEL"
With RelationSheet.Range(START_CELL)
.AutoFilter Field:=4, Criteria1:=desk
.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
End With
sht.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
sht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
With ActiveWindow
If .FreezePanes Then .FreezePanes = False
.SplitColumn = 1
.SplitRow = 2
.FreezePanes = True
End With
Application.CutCopyMode = False
RelationSheet.ShowAllData
RelationSheet.AutoFilterMode = False
End Sub
Я не знаю, как добавить в код второй фильтр, чтобы создавать дополнительные книги для каждого человека.
В приведенном ниже примере выбор «Рабочий стол 1» и последующий запуск макроса (с помощью кнопки) должны создать две отдельные книги; один для Анастасии и один для Роба. В названии каждого отчета должно сочетаться название отдела и имя человека, например: «Рабочий стол_1_Анастасия».
Если комбинации «рабочий стол+человек» нет, будет создан пустой отчет (= скопировать заголовок таблицы в отчет).
Таблица сопоставления:
Я подготовил Excel с фиктивными данными, чтобы лучше проиллюстрировать исходные данные:
Понятно. Остальные части я удалил, чтобы оставить этот пост исключительно о фильтрации для стола и последующем создании для каждого человека в этом столе отдельного отчета.
Для чего нужна таблица сопоставления?
Чтобы знать, к какому столу принадлежит каждый человек. Моя идея заключалась в том, чтобы использовать его как своего рода поиск, чтобы код знал: «Стол 1 -> Анастасии и Робу нужен отчет».
Desk 1 -> Anastasia and RobЭто отчет или два отчета? Если в таблицах нет строки объединения «рабочий стол+человек», хотите ли вы пропустить комбинацию или просто скопировать заголовок таблицы в отчет? Как называется файл отчета? Пожалуйста, предоставьте подробную информацию о вашем вопросе.
Отредактировал сообщение, добавив недостающую информацию. Стол 1 -> Анастасия и Роб должны быть двумя отдельными отчетами. Оба отчета должны быть созданы при выборе Стола 1 и последующем запуске макроса (с помощью кнопки). Если комбинация недоступна, следует просто скопировать заголовок таблицы в отчет. Все отчеты должны иметь формат «Desk_X_Person Name», например: «Рабочий стол_1_Анастасия».
Ответы 1
- Исходные данные форматируются в виде таблицы (Вставка > Таблица) в вашем файле. Использование
ListObjectупрощает управление.
Документация Майкрософт:
Option Explicit
Sub copy_data()
Dim RelationSheet As Worksheet
Dim AccountSheet As Worksheet
Dim InstructionSheet As Worksheet
Dim wb As Workbook, sht, desk As String
Dim rngLookUp As Range, i As Long, sDesk As String, sPerson As String
Dim arrData, sFile As String, sPath As String
sPath = ThisWorkbook.Path & "\"
Set InstructionSheet = Sheet2
Set RelationSheet = Sheet1
Set AccountSheet = Sheet3
desk = InstructionSheet.Cells(14, 3).Text
If Len(desk) = 0 Then Exit Sub
' load lookup table into an array
With InstructionSheet.Range("M1").CurrentRegion
arrData = .Resize(.Rows.Count - 1).Offset(1).Value
End With
Application.ScreenUpdating = False
' loop through lookup table
For i = LBound(arrData) To UBound(arrData)
sDesk = arrData(i, 1)
If sDesk = desk Then ' match desk
sPerson = arrData(i, 2)
' report workbook name
sFile = Replace(sDesk, " ", "_") & "_" & sPerson & ".xlsx"
Set wb = Workbooks.Add
Set sht = ActiveSheet
sht.Name = RelationSheet.Name
With RelationSheet.ListObjects(1)
If .AutoFilter.FilterMode Then
.AutoFilter.ShowAllData
End If
' filter desk and person
.Range.AutoFilter Field:=4, Criteria1:=sDesk
.Range.AutoFilter Field:=2, Criteria1:=sPerson
' copy filtered table
.Range.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
.AutoFilter.ShowAllData
End With
' add a new sheet for AccountLevel
Set sht = wb.Sheets.Add
sht.Name = AccountSheet.Name
With AccountSheet.ListObjects(1)
If .AutoFilter.FilterMode Then
.AutoFilter.ShowAllData
End If
.Range.AutoFilter Field:=1, Criteria1:=sDesk
.Range.AutoFilter Field:=2, Criteria1:=sPerson
.Range.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
.AutoFilter.ShowAllData
End With
Application.DisplayAlerts = False
' save report, overwrite if exists
wb.SaveAs sPath & sFile
Application.DisplayAlerts = True
wb.Close
End If
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Большое спасибо, это отлично работает в файле примера. Но код не работал в реальном файле, и после некоторого тестирования я понял, что это потому, что моя «таблица» на УРОВНЕ ОТНОШЕНИЙ является сводной таблицей. На УРОВНЕ АККАУНТА это обычная таблица. В сводной таблице этот код всегда приводит к ошибке («Ошибка метода автофильтра класса Range»). Очень извиняюсь, не знал, что есть разница при копировании с Pivots. Я обновлю свой вопрос. Подскажите, пожалуйста, есть ли простой способ настроить его?
Спасибо, я вернул сообщение обратно, чтобы другие могли использовать вышеуказанное решение. Опубликую продолжение!
Было бы полезно ответить на один вопрос в каждом посте. После решения текущей проблемы вы можете создать новую публикацию, если у вас возникнут дополнительные вопросы.