Нужен код VBA, чтобы выбрать листы, соответствующие именам в списке, а затем сохранить в новую книгу

Question

У меня есть немного сложный VBA, который я пытаюсь создать. В настоящее время у меня есть два других макроса, которые ищут два листа для имен поставщиков и создают новые листы с их конкретной информацией. Это оставляет мне около 40 листов, теперь я пытаюсь написать макрос, который будет искать имя поставщика в заголовке листа и сохранять все листы, связанные с этим поставщиком, в новую книгу (если файл существует обновление текущие листы в этой книге). У меня будет список поставщиков на одном листе, который я бы хотел использовать в качестве критериев поиска. Вот пример первого макроса я бег

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 

А вот где я получил с помощью этого и recoring моего собственного макроса, но не понял, как создать функцию массива с переменными, полученными из поиска, или заставить поиск работать при создании c.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 

предлагаем посетить следующие страницы:

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