VBA to search sheets and save sheets containing *name to new workbook

[B_Rob]

Hi All,

New to the form, I have a little tricky VBA I'm trying to create. What I currently have is two other macros which search two sheets for vendor names and creates new sheets with their specific information. This leaves me with approx 40 sheets, now what I'm trying to do is write a macro that will search for the vendor name in the sheet tile and save all the sheets associated with that vendor to a new workbook (if one exists update the current sheets in that workbook). I will have a list of vendors in one sheet that I would like to use as the search criteria. Here is an example of the first macro I run
Option Explicit

' Developed by Contextures Inc.
' www.contextures.com


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

Looking around and trying to copy that has left me with this VBA which doesn't work (just for testing I'm hard coding the look up name)

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

 

[Teeroy]

Hi and welcome to the forum.

You haven't specified what error you receive but I'm guessing run-time error 91 as you've Dimensioned C as a Range then assigned a String to the variable.

See below for the concepts you need to correct your test code (the final may be a little different).

Sub Show_WS_Test()
Dim c as String

c = "VendorA"
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "*" & c & "*" Then
        MsgBox ws.Name
    End If
Next
End Sub

 

[B_Rob]

@Teeroy So there was several errors it basically didn't run but here is where I am at now, I can search sheets if I manually type in what I'm looking for and save them to a new workbook. The issues I have now is I want the logic to look for the search criteria in a Range "Disti_list" and I want the file name to start with that variable. Now the other kicker is when its copying the sheets over I don't want to overwrite the whole workbook as I will have a Pivot sheet in there that I would like to maintain. I just want to over write the few sheets that have the same name with new data if it exists. Here is where I am at thus far;

Option ExplicitOption Base 1 'Ensure to have this command at the top of the module


Sub Wsh_Find_And_Copy_To_New_Wbk()
Dim sPathFilename As String
sPathFilename = "C:\Users\brobbin\Desktop\L121ley.xlsx" 'Change as required
Dim sKey As String
Dim rng As Range
Dim Wsh As Worksheet, aWsh() As String
Dim r As Integer
Dim c As String
sKey = c 'Change as required
Set rng = Range("Disti_list")
 r = .Cells(Rows.Count, "H").End(xlUp).Row
For Each c In .Range("H2:H" & r)
    
    Rem Get Worksheet Array To Be Copied Into A New Wbk
    sKey = "*" & sKey & "*"
    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
    ThisWorkbook.Sheets(aWsh).Copy
    ActiveWorkbook.SaveAs Filename:=sPathFilename, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


End Sub