Это то, что я в основном использую, чтобы делать именно то, о чем вы говорите. У меня есть «основной» лист, который состоит из нескольких тысяч строк и пары сотен столбцов. Эта базовая версия выполняет поиск только в столбце Y, а затем копирует строки. Однако, поскольку другие люди используют это, у меня есть несколько таблиц шаблонов, которые я очень скрываю, так что вы можете отредактировать их, если не хотите использовать шаблоны. Я также могу добавить дополнительные переменные поиска, если это необходимо, и просто добавить еще пару строк достаточно просто. Поэтому, если вы хотите скопировать строки, которые соответствуют двум переменным, вы должны определить другую переменную Dim d as Range и Set d = shtMaster.Range("A1") или любой другой столбец, в котором вы хотите найти вторую переменную. Затем в строке If измените его на If c.Value = "XXX" and d.Value = "YYY" Тогда. Наконец, убедитесь, что вы добавили смещение для новой переменной с помощью c.offset (чтобы в нижней части была строка Set d = d.Offset(1,0) с другой). Это действительно оказалось довольно гибким для меня.
Sub CreateDeptReport(Extras As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, x As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 3, 4, 8, 25, 25, 21, 16, 17, 15, 31, 7) 'which columns to copy ?
Set shtMaster = ThisWorkbook.Sheets("MasterSheet")
Set c = shtMaster.Range("Y5") 'Start search in Column Y, Row 5
LCopyToRow = 10 'Start copying data to row 10 in Destination Sheet
While Len(c.Value) > 0
'If value in column Y equals defined value, copy to destination sheet
If c.Value = “XXX” Then
'only create the new sheet if any records are found
If shtRpt Is Nothing Then
'delete any existing sheet
On Error Resume Next
ThisWorkbook.Sheets("Destination").Delete
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtMaster
Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
shtRpt.Name = "Destination" 'rename new sheet to Destination
‘Optional Information; can edit the next three lines out -
Range("F1").Value = "Department Name"
Range("F2").Value = "Department Head Name"
Range("B3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A9").Select 'Position on cell A9
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Кроме того, если вы хотите, вы можете удалить строки обновления экрана. Как бы глупо это ни звучало, некоторым людям на самом деле нравится видеть, как Excel работает над этим. При отключенном обновлении экрана вы не сможете увидеть лист назначения до тех пор, пока копирование не будет завершено, но с обновлением на экране мерцает, как сумасшедший, потому что он пытается обновить, когда копируется каждая строка. Некоторые пожилые люди в моем офисе думают, что Excel нарушается, когда не видят, как это происходит, поэтому я продолжаю обновлять экран большую часть времени. лол
Кроме того, мне нравится иметь шаблоны, потому что во всех моих отчетах есть довольно много формул, которые нужно вычислять после разбивки информации, чтобы я мог хранить все формулы там, где я хочу, с шаблоном. Затем все, что мне нужно сделать, это запустить макрос для извлечения из мастер-листа, и отчет готов к работе без дальнейшей работы.