Question

我有一点点狡猾的VBA，我试图创造。我目前拥有的是另外两个宏，它们搜索两张供应商名称并使用其特定信息创建新工作表。这给我留下了大约40张，现在我要做的就是编写一个宏来搜索工作表标题中的供应商名称，并将与该供应商相关的所有工作表保存到新工作簿中（如果是文件） exists更新该工作簿中的当前工作表）。我将在一张表中列出供我用作搜索条件的供应商列表。以下是我运行的第一个宏的示例

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

这里是我使用它并记录我自己的宏但尚未弄清楚如何使用从搜索派生的变量创建数组函数，或者让搜索在创建c时工作。值。

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

建议访问以下页面：

Excel Objects，For Each...Next Statement，On Error Statement Range Object (Excel)，Variables & Constants，Workbook Object (Excel) Worksheet Object (Excel)，With Statement

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

1 个答案: