VBA for copy several worksheets with similar name (except for last character) to a new workbook

chika235

New Member
Joined
Aug 7, 2014
Messages
18
Hi guys,

I hope you could please help me with this. I have tried everything i could to make the below codes work but it hasn't gone very well :mad:

I have a workbook of 4 worksheets: ALPHA, BETA, ALPHA1, BETA1.

All I wanted to do is to have 2 workbooks:

- Copy both ALPHA & ALPHA1 into a new workbook, and name the new workbook as ALPHA (which is the 1st sheet name) - 1st workbook
- Copy both BETA & BETA1 into a new workbook, and name the new workbook as BETA (which is the 1st sheet name) - 2nd workbook

Originally, i have tried to use this code:

Code:
Sub Test1()
'
' Test1 Macro

    Dim ws As Worksheet
    Dim oldwb As Workbook
    Dim newwb As Workbook
    
    Set oldwb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\ALPHABETA.xlsx")
    
    Application.ScreenUpdating = False

    For Each ws In oldwb.Sheets
    
    If ws.Name Like "ALPHA*" Then
    
        ws.Copy
        Application.DisplayAlerts = False
    
        ActiveWorkbook.SaveAs Filename:=oldwb.Path & "\" & ActiveSheet.Name, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    
    ElseIf ws.Name Like "BETA*" Then
    
    ws.Copy
    Application.DisplayAlerts = False
    
        ActiveWorkbook.SaveAs Filename:=oldwb.Path & "\" & ActiveSheet.Name, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    
    Else
    
    oldwb.Activate
    
    End If
    
    Next ws
    
    oldwb.Close False

    End Sub

The problem with "Test1" (or the above code) is that it extracts every single worksheets into single workbooks (i.e: end result I have 4 workbooks: ALPHA, ALPHA1, BETA, BETA1).

I went on and thought maybe I tried a bit of an old way, by saying that I mean less automated (but automated) :ROFLMAO:

Code:
Sub Test2()
'
' Test2 Macro
'

'

    Dim ws As Worksheet
    Dim oldwb As Workbook
    Dim newwb As Workbook
    
    Set oldwb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\ALPHABETA.xlsx")
    
    Application.ScreenUpdating = False

    Sheets(Array("ALPHA", "ALPHA1")).Select
    Selection.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=oldwb.Path & "\" & ActiveSheet.Name, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close False

    Sheets(Array("BETA", "BETA1")).Select
    Selection.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=oldwb.Path & "\" & ActiveSheet.Name, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False

    ActiveWorkbook.Close False

    oldwb.Close False

    End Sub

This Test2 gave a new workbook with all ALPHA, ALPHA1, BETA, BETA1 worksheet copied into the same workbook (DO ABSOLUTELY NOTHING :oops: except for saving the oldwb as ALPHA workbook).

I don't know what I have gone WRONG, and seriously curious to know how I could fix this to make it work? Still a novice to VBA so either code is OK for as long as it works :eek:

Thanks all in advance and if my post is too long - my sincere apologies.

Chika.
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Forum statistics

Threads
1,213,558
Messages
6,114,296
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top