Question

我当前的代码将在列A中搜索名为“Temp”的工作表中的特定字符串名称。从那里，代码将匹配的行复制到工作表“Table1”并将输出保存到我的桌面。

    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

我希望此代码完成的任务是阅读团队名称列表并循环以完成上述步骤。

我找到的代码会给我一个明确的名单列表，这些名称列在我需要的工作表Temp列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

用于填充表的Excel VBA数组

1 个答案: