Excel массив VBA для заполнения таблиц

Question

Мой текущий код будет искать столбец A для определенного имени строки на листе с именем «Temp». Оттуда код скопирует совпадающие строки на рабочий лист «Таблица1» и сохранит вывод на моем рабочем столе.

Sub Find_Team() 
    Dim rngData As Range 
    Dim rngFound As Range, firstAddress As String 
    Dim wsNew As Worksheet 
    Const strFindMe As String = "Team A" 

    Application.ScreenUpdating = False 

    With ThisWorkbook.Worksheets("Temp") 
     Set rngData = .Range("A3:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) 
    End With 
    Set wsNew = ThisWorkbook.Worksheets("Table1") 

    With rngData 
     Set rngFound = .Find(strFindMe, LookIn:=xlValues) 
     If Not rngFound Is Nothing Then 
      firstAddress = rngFound.Address 
      Do 
       rngFound.EntireRow.Copy 
       wsNew.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial 
       Set rngFound = .FindNext(rngFound) 
      Loop While Not rngFound Is Nothing And rngFound.Address <> firstAddress 
     End If 
    End With 

    Application.ScreenUpdating = True 

    Call SavSheets 
End Sub 

Sub SavSheets() 
Dim InitFileName As String, fileSaveName As String 

fileSaveName = "C:Desktop\ " & Format(Date, "yyyymmdd") 
Worksheets(Array("Table 1", "Table 2", "Table 3", "Table 4", "Table 5", "Table 6", "Table 7", "Table 8")).Copy  
Set wbNew = ActiveWorkbook 
With wbNew 
.SaveAs fileSaveName 
    .Close 
End With 
End Sub 

Что я хотел бы для этого кода, чтобы выполнить это прочитать в списке имен команды и петли для выполнения действий, описанных выше.

Я нашел код, который даст мне отличный список имен, которые находятся в моем листе столбца Темп A1, который мне понадобится.

Любые предложения о том, как это сделать?

Sub Unique_Names() 
Dim X 
Dim objDict As Object 
Dim lngRow As Long 
Sheets("Temp").Select 
Set objDict = CreateObject("Scripting.Dictionary") 
X = Application.Transpose(Range([A1], Cells(Rows.Count, "A").End(xlUp))) 

For lngRow = 1 To UBound(X, 1) 
    objDict(X(lngRow)) = 1 
Next 
Range("N1:N" & objDict.Count) = Application.Transpose(objDict.keys) 
End Sub 

Answer 1

Если вы даете каждому листу имя команды, вы можете использовать автофильтр:

Sub M_snb() 
for each sh in sheets 
    if sh.name<>"temp" then 
    with sheets("temp").cells(1).currenregion 
     .autofilter 1, sh.name 
     .copy sh.cells(1) 
     .autofilter 
    end with 
    end if 
next 
end sub