需要VBA代码来select列表中匹配名称的表，然后保存到一个新的工作簿

我有一个棘手的VBA，我正在尝试创build。 我目前拥有的是另外两个macros，它们search两张供应商名称，并用他们的特定信息创build新的工作表。 这使我大约40张，现在我想要做的是写一个macros，将在工作表标题中search供应商名称，并保存与该供应商关联的所有工作表到一个新的工作簿（如果文件存在更新该工作簿中的当前工作表）。 我将在一张表中列出我想用作search条件的供应商列表。 这里是我运行的第一个macros的例子

Sub ERP_POS() Dim ws1 As Worksheet Dim wsNew As Worksheet Dim rng As Range Dim r As Integer Dim c As Range Dim bAF As Boolean Set ws1 = Sheets("ERP_POS") Set rng = Range("Database") bAF = ws1.AutoFilterMode 'extract a list of Sales Reps With ws1 .Columns("P:P").Copy _ Destination:=.Range("X1") .Columns("X:X").AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("Y1"), Unique:=True r = .Cells(Rows.Count, "Y").End(xlUp).Row .Columns("X:X").ClearContents 'set up Criteria Area .Range("X1").Value = .Range("P1").Value For Each c In .Range("Y2:Y" & r) 'add the rep name to the criteria area .Range("X2").Value = _ "=""="" & " & Chr(34) & c.Value & Chr(34) 'add new sheet (if required) 'and run advanced filter If WksExists("ERP_POS" & " " & c.Value) Then Sheets("ERP_POS" & " " & c.Value).Cells.Clear rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("X1:X2"), _ CopyToRange:=Sheets("ERP_POS" & " " & c.Value).Range("A1"), _ Unique:=False Else Set wsNew = Sheets.Add wsNew.Move After:=Worksheets(Worksheets.Count) wsNew.Name = "ERP_POS" & " " & c.Value rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=.Range("X1:X2"), _ CopyToRange:=wsNew.Range("A1"), _ Unique:=False End If Next .Select .Columns("Y:X").EntireColumn.Delete If bAF = True Then .Range("A1").AutoFilter End If End With End Sub Function WksExists(wksName As String) As Boolean On Error Resume Next WksExists = CBool(Len(Worksheets(wksName).Name) > 0) End Function 

这里是我得到的使用和logging我自己的macros，但还没有想出如何创build数组函数与从search派生的variables，或获得search工作创buildc.value。

 Sub Test1234() ' ' Test1234 Macro ' Dim ws As Worksheet Dim ws2 As Worksheet ws = Worksheet.Name For Each ws In ActiveWorkbook.Worksheets If ws.Name Like "*CompanyA*" Then Set ws2 = Worksheet.Name Sheets(ws2).Select Sheets(ws2).Copy ActiveWorkbook.SaveAs filename:="C:\Users\xxxxx\Desktop\Lovley.xlsx", _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False End If Next ws End Sub 

Answer 1

试试这个代码：

 Option Explicit Option Base 1 'Ensure to have this command at the top of the module Sub Lst_Vendors_Wbk_Set() Const kPath As String = "D:\StackOverFlow\Answers\" 'Change as required Dim rTrg As Range, rCll As Range, sVendor As String 'Assuming list of vendors is located at Wsh [Vendors] Column [A] - change as required With ThisWorkbook.Sheets("Vendors") Rem Set Target Range Set rTrg = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row) Rem Work List of Vendors For Each rCll In rTrg.Cells sVendor = rCll.Value2 If Not sVendor = Empty Then If Not (Wsh_Find_And_Copy_To_New_Wbk(sVendor, kPath)) Then MsgBox "No sheet found for vendor: [" & sVendor & "]" End If: End If: Next: End With End Sub Function Wsh_Find_And_Copy_To_New_Wbk(sKey As String, sPathFilename As String) As Boolean Dim Wsh As Worksheet, aWsh() As String Rem Validate Key If sKey = Empty Then GoTo ExitTkn Rem Get Worksheet Array To Be Copied Into A New Wbk If IsEmpty(aWsh) Then Stop For Each Wsh In ThisWorkbook.Worksheets If Wsh.Name Like "*" & sKey & "*" Then On Error Resume Next ReDim Preserve aWsh(1 + UBound(aWsh)) If err.Number <> 0 Then ReDim Preserve aWsh(1) On Error GoTo 0 aWsh(UBound(aWsh)) = Wsh.Name End If: Next Rem Copy Worksheet Array Into A New Wbk On Error GoTo ExitTkn ThisWorkbook.Sheets(aWsh).Copy ActiveWorkbook.SaveAs Filename:=sPathFilename & sKey, _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Rem Set Results Wsh_Find_And_Copy_To_New_Wbk = True ExitTkn: End Function 

build议访问以下页面：

Excel对象 ， 对于每个…下一个语句 ， 在错误语句 范围对象（Excel） ， variables和常量 ， 工作簿对象（Excel） 工作表对象（Excel）