Copy specific sheets to a new workbook

[Martin sherk]

so i have a workbook with sheets that have data based on customer codes , for Ex: company code USA1 has 3 sheets: (USA1, USA1 distributors and USA1 PVT) Like elaborated in the pic below.

what i need is:
A VBA code to copy all data of these 3 sheets that starts with USA1 and paste it in a new workbook and name it USA1 Payments then save and close that workbook.

please note that i have 6 other company codes that goes like this USA2, USA3, USA4 and so on and each company code has 3 sheets as well.

I Appreciate your time reading this and thanks in advance.

 

[HaHoBe]

Hi Martin,

copy all 3 sheets to 3 different sheets in the new workbook or merge data on one sheet?

What about

Sub Sheets2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long

Const cstrStart As String = "USA1"

For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    lngCounter = lngCounter + 1
    varArr(lngCounter) = ws.Name
    If lngCounter = 3 Then Exit For
  End If
Next ws

Worksheets(varArr).Copy

For Each ws In ActiveWorkbook.Worksheets
  With ws.UsedRange
    .Value = .Value
  End With
Next ws

With ActiveWorkbook
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

End Sub

or

Sub SheetsMerged2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws        As Worksheet
Dim wbNew     As Workbook
Dim wsNew     As Worksheet

Const cstrStart As String = "USA1"

Set wbNew = Workbooks.Add
Set wsNew = wbNew.Worksheets(1)

For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    With ws.UsedRange
      wsNew.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
  End If
Next ws


With wbNew
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

 

[Martin sherk]

Hi Martin,

copy all 3 sheets to 3 different sheets in the new workbook or merge data on one sheet?

What about

Sub Sheets2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long

Const cstrStart As String = "USA1"

For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    lngCounter = lngCounter + 1
    varArr(lngCounter) = ws.Name
    If lngCounter = 3 Then Exit For
  End If
Next ws

Worksheets(varArr).Copy

For Each ws In ActiveWorkbook.Worksheets
  With ws.UsedRange
    .Value = .Value
  End With
Next ws

With ActiveWorkbook
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

End Sub

or

Sub SheetsMerged2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws        As Worksheet
Dim wbNew     As Workbook
Dim wsNew     As Worksheet

Const cstrStart As String = "USA1"

Set wbNew = Workbooks.Add
Set wsNew = wbNew.Worksheets(1)

For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    With ws.UsedRange
      wsNew.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
  End If
Next ws


With wbNew
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

Set wsNew = Nothing
Set wbNew = Nothing
End Sub

Ciao,
Holger

Hello Sir, I need to have 3 separate sheets and not merge them into 1 sheet.

I tried the first VBA code and got error in this line saying subscript out of range:
Worksheets(varArr).Copy

I tried the second code and all it did was open a new workbook and new sheet then do nothing.

 

[Martin sherk]

@HaHoBe also please note that the code is not in the same file

 

[Martin sherk]

@HaHoBe I tried it again by inserting the code in the workbook itself and it worked fine but it just copies USA1 and not the other codes like US2 and US2

sorry if I forgot to mention but if there are sheets with US2 instead of USA2, how can I modify the code to copy them?

Should i make 7 VBA codes and change the numbers in that line:

Const cstrStart As String = "US2"
Const cstrStart As String = "US3"
Const cstrStart As String = "US4"
Const cstrStart As String = "US5"

 

[HaHoBe]

Hi Martin,

ThisWorkbook means that anything has to happen in the workbook which holds the code, if you want the code to work on an active workbook you can try

Sub SheetsAW2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long

Const cstrStart As String = "USA1"

For Each ws In ActiveWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    lngCounter = lngCounter + 1
    varArr(lngCounter) = ws.Name
    If lngCounter = 3 Then Exit For
  End If
Next ws

ActiveWorkbook.Worksheets(varArr).Copy

For Each ws In ActiveWorkbook.Worksheets
  With ws.UsedRange
    .Value = .Value
  End With
Next ws

With ActiveWorkbook
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

End Sub

Or you use Workbooks("YourWorkbookToExport.xlsx") instead of ActiveWorkbook.

The following code will loop through all the items listed in the array:

Sub SheetsAW2NewWorkbookMultipleCrit()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long
Dim varNames          As Variant
Dim lngNames          As Long
Dim wbAct             As Workbook

Set wbAct = ActiveWorkbook
varNames = Array("USA1", "USA2", "USA3", "USA4", "USA5", "USA6")
For lngNames = LBound(varNames) To UBound(varNames)
  lngCounter = 0
  For Each ws In wbAct.Worksheets
    If Left(ws.Name, Len(varNames(lngNames))) = varNames(lngNames) Then
      lngCounter = lngCounter + 1
      varArr(lngCounter) = ws.Name
      If lngCounter = 3 Then Exit For
    End If
  Next ws
  
  wbAct.Worksheets(varArr).Copy
  
  For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
      .Value = .Value
    End With
  Next ws

  With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\" & varNames(lngCounter) & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
    .Close False
  End With
Next lngNames

Set wbAct = Nothing
End Sub

Ciao,
Holger

 

[Martin sherk]

Hi Martin,

ThisWorkbook means that anything has to happen in the workbook which holds the code, if you want the code to work on an active workbook you can try

Sub SheetsAW2NewWorkbook()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long

Const cstrStart As String = "USA1"

For Each ws In ActiveWorkbook.Worksheets
  If Left(ws.Name, Len(cstrStart)) = cstrStart Then
    lngCounter = lngCounter + 1
    varArr(lngCounter) = ws.Name
    If lngCounter = 3 Then Exit For
  End If
Next ws

ActiveWorkbook.Worksheets(varArr).Copy

For Each ws In ActiveWorkbook.Worksheets
  With ws.UsedRange
    .Value = .Value
  End With
Next ws

With ActiveWorkbook
  .SaveAs ThisWorkbook.Path & "\" & cstrStart & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
  .Close False
End With

End Sub

Or you use Workbooks("YourWorkbookToExport.xlsx") instead of ActiveWorkbook.

The following code will loop through all the items listed in the array:

Sub SheetsAW2NewWorkbookMultipleCrit()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long
Dim varNames          As Variant
Dim lngNames          As Long
Dim wbAct             As Workbook

Set wbAct = ActiveWorkbook
varNames = Array("USA1", "USA2", "USA3", "USA4", "USA5", "USA6")
For lngNames = LBound(varNames) To UBound(varNames)
  lngCounter = 0
  For Each ws In wbAct.Worksheets
    If Left(ws.Name, Len(varNames(lngNames))) = varNames(lngNames) Then
      lngCounter = lngCounter + 1
      varArr(lngCounter) = ws.Name
      If lngCounter = 3 Then Exit For
    End If
  Next ws
 
  wbAct.Worksheets(varArr).Copy
 
  For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
      .Value = .Value
    End With
  Next ws

  With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\" & varNames(lngCounter) & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
    .Close False
  End With
Next lngNames

Set wbAct = Nothing
End Sub

Ciao,
Holger

it worked smoothly but unfourtnetly copied some wrong sheets together, for ex in USA6, as you can see in the pic below. it copied USA5 sheet with USA6 PVT sheet and USA5 PVT sheet

 

[HaHoBe]

Hi Martin,

I can - there are only 2 sheets starting wirth USA6 in the workbook so the third value for the array stays as it was. And there was an error with naming the newly created files. I changed the code to:

Sub SheetsAW2NewWorkbookMultipleCrit()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long
Dim varNames          As Variant
Dim lngNames          As Long
Dim wbAct             As Workbook

Set wbAct = ActiveWorkbook
varNames = Array("USA1", "USA2", "USA3", "USA4", "USA5", "USA6")
For lngNames = LBound(varNames) To UBound(varNames)
  lngCounter = 0
  For Each ws In wbAct.Worksheets
    If Left(ws.Name, Len(varNames(lngNames))) = varNames(lngNames) Then
      lngCounter = lngCounter + 1
      varArr(lngCounter) = ws.Name
      If lngCounter = 3 Then Exit For
    End If
  Next ws
  
  wbAct.Worksheets(varArr).Copy
  
  For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
      .Value = .Value
    End With
  Next ws

  With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\" & varNames(lngNames) & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
    .Close False
  End With
  Erase varArr
Next lngNames

Set wbAct = Nothing
End Sub

Ciao,
Holger

 

[Martin sherk]

Hi Martin,

I can - there are only 2 sheets starting wirth USA6 in the workbook so the third value for the array stays as it was. And there was an error with naming the newly created files. I changed the code to:

Sub SheetsAW2NewWorkbookMultipleCrit()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr(1 To 3)    As Variant
Dim lngCounter        As Long
Dim varNames          As Variant
Dim lngNames          As Long
Dim wbAct             As Workbook

Set wbAct = ActiveWorkbook
varNames = Array("USA1", "USA2", "USA3", "USA4", "USA5", "USA6")
For lngNames = LBound(varNames) To UBound(varNames)
  lngCounter = 0
  For Each ws In wbAct.Worksheets
    If Left(ws.Name, Len(varNames(lngNames))) = varNames(lngNames) Then
      lngCounter = lngCounter + 1
      varArr(lngCounter) = ws.Name
      If lngCounter = 3 Then Exit For
    End If
  Next ws
 
  wbAct.Worksheets(varArr).Copy
 
  For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
      .Value = .Value
    End With
  Next ws

  With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\" & varNames(lngNames) & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
    .Close False
  End With
  Erase varArr
Next lngNames

Set wbAct = Nothing
End Sub

Ciao,
Holger

i am so sorry that i forgot to mention, but for USA5 and USA6 sometimes we don't have this sheet (USA5 distributors) it depends on the month so for USA5 and USA6 this month we have only 2 sheets, not 3 which are (USA5 and USA5 PVT), (USA6 and USA6 PVT).

 

[HaHoBe]

Hi Martin,

my bad - the array I used expects three sheets. So we will not work with a static arrays but one which is filled according to the number of sheets. As I allowed to work on any number of sheets for an item I must let the first loop work on all worksheets and decide if any sheets were added to the array like

Sub SheetsAW2NewWorkbookMultipleCrit_V3()
'https://www.mrexcel.com/board/threads/copy-specific-sheets-to-a-new-workbook.1220118/

Dim ws                As Worksheet
Dim varArr()          As Variant
Dim lngCounter        As Long
Dim varNames          As Variant
Dim lngNames          As Long
Dim wbAct             As Workbook

Set wbAct = ActiveWorkbook
varNames = Array("USA1", "USA2", "USA3", "USA4", "USA5", "USA6")
For lngNames = LBound(varNames) To UBound(varNames)
  lngCounter = 0
  For Each ws In wbAct.Worksheets
    If Left(ws.Name, Len(varNames(lngNames))) = varNames(lngNames) Then
      lngCounter = lngCounter + 1
      ReDim Preserve varArr(1 To lngCounter)
      varArr(lngCounter) = ws.Name
    End If
  Next ws
  
  If lngCounter > 0 Then
    wbAct.Worksheets(varArr).Copy
    
    For Each ws In ActiveWorkbook.Worksheets
      With ws.UsedRange
        .Value = .Value
      End With
    Next ws
  
    With ActiveWorkbook
      .SaveAs ThisWorkbook.Path & "\" & varNames(lngNames) & " Payments " & Format(Now, "yymmdd_hhmmss") & ".xlsx", FileFormat:=51
      .Close False
    End With
  End If
  Erase varArr
Next lngNames

Set wbAct = Nothing
End Sub

Ciao,
Holger