VBA Excel Sheets with similar names to new workbook

I need to copy sheets with similar names to a new workbook.  So if there are sheets

SHeetA
SheetA (1)
SheetA (2)
Would all copy Range A1:C34 to the new sheet starting at A1 and shifting based on the number of sheets it copies.  So the Values of SheetA (1) would be pasted starting at E1 skipping one column.

You could also have just a single sheet

SheetB

Which would just be copied to a new workbook.  Coping range A1:C34 to the new workbook and pasting it to A1.

Thanks,
Montrof
LVL 1
montrofAsked:
Who is Participating?
 
gowflowCommented:
Ok I created a sample workbook for you that is attached with the code below.

It has 2 sub the first one with sort the workbook in ascending order so the sheets that have the same name follows and the second one will process to export the sheet like you advised before.

Just to test it put this workbook in a folder that you create with no other files and open it activate macros and select the Macro called CreateWB and run it. Check the results in the folder and compare with the initial data in the file. Please note that I have added Col D and Row 35 downward some data but as you mentioned only to export A1:C34 I only exported this and not the rest of data.

Let me know.

Here is the code that you will find in the workbook.

Option Explicit

Sub Sort_Active_Book()
Dim I As Integer
Dim J As Integer
Dim iAnswer As VbMsgBoxResult
Dim bNoPrompt As Boolean

bNoPrompt = True
' Do not Prompt the user as which direction they wish to
' sort the worksheets.
'
If Not bNoPrompt Then
     iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
         & "Clicking No will sort in Descending Order", _
         vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
 Else
     iAnswer = vbYes
 End If
    
   For I = 1 To Sheets.Count
      For J = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
         If iAnswer = vbYes Then
            If UCase$(Sheets(J).Name) > UCase$(Sheets(J + 1).Name) Then
               Sheets(J).Move after:=Sheets(J + 1)
            End If
'
' If the answer is No, then sort in descending order.
'
         ElseIf iAnswer = vbNo Then
            If UCase$(Sheets(J).Name) < UCase$(Sheets(J + 1).Name) Then
               Sheets(J).Move after:=Sheets(J + 1)
            End If
         End If
      Next J
   Next I
End Sub


Sub CreateWB()
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim WB As Workbook
Dim ThisWB As Workbook
Dim I As Long, LCol As Long
Dim vSheet
Dim TSheet As String, LSheet As String
Dim Rng As Range

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---> Sort This workbook
Sort_Active_Book


'---> Set Variables
Set ThisWB = ActiveWorkbook

'---> Start Process
For Each WS In ThisWB.Worksheets
    '---> Store first full word of the name
    vSheet = Split(WS.Name, " ")
    TSheet = vSheet(0)
    
    If TSheet <> LSheet Then
        '---> Close the workbook if already opened
        If Not WB Is Nothing Then
            WSNew.UsedRange.EntireColumn.AutoFit
            WB.Close savechanges:=True
            Set WB = Nothing
            Set WSNew = Nothing
        End If
        
        '---> Create a New Workbook with the current sheet
        WS.Copy
        Set WB = ActiveWorkbook
        Set WSNew = WB.ActiveSheet
        WSNew.Range(WSNew.Columns("D"), WSNew.Columns(WSNew.Columns.Count)).EntireColumn.Delete
        WSNew.Range("35:" & WSNew.Rows.Count).EntireRow.Delete
        WB.SaveAs Filename:=ThisWB.Path & "\" & TSheet & ".xlsx"
        LCol = 5
        LSheet = TSheet
    Else
        WS.Range("A1:C34").Copy WSNew.Cells(1, LCol)
        LCol = LCol + 4
    End If
Next WS

'---> Close the workbook if already opened
If Not WB Is Nothing Then
    WSNew.UsedRange.EntireColumn.AutoFit
    WB.Close savechanges:=True
    Set WB = Nothing
    Set WSNew = Nothing
End If
        
MsgBox "Worksheets Exported Successfully", vbExclamation

'---> Enable Events
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Open in new window



Gowflow
Main.xlsm
0
 
NorieVBA ExpertCommented:
Do you know the (partial) names of the sheets you want to copy from?

For example 'SheetA'.
0
 
gowflowCommented:
What if in a workbook you have

Sheet1
Sheet1 A
Sheet2
Sheet3
SheetA
SheetA (1)
SheetA (2)

It is clear for SheetA but what about Sheet2, Sheet3 ?? are they ignored ?
and for Sheet1 who also have a similar sheet Sheet1 A do we save it in same workbook as SheetA or a new one ??

Best is to post a sample workbook.
gowflow
and if
0
Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

 
montrofAuthor Commented:
So in your example above all sheets would end in (#) so SheetA  SheetA (1) and SheetA (2) would all be copied to a new workbook and Saved.  The other sheets would each go to an individual new workbook.   So all the sheets that have multiple sheets with the same name would end in (#).  

Thanks,
Montrof
0
 
gowflowCommented:
So basically in my example you will get the following for which pls confirm:

Workbook1
sheet1 (will contain Sheet1  and Sheet1 A)

Workbook2
Sheet1 (will contain Sheet2)

Workbook3
Sheet1 (will contain Sheet3)

Workbook4
Sheet1 (will contain SheetA, SheetA (1), SheetA (2))

For sure all of them we copy Range A1:C34
pls confirm.
gowflow
0
 
montrofAuthor Commented:
Yes that is correct.  

Thanks,
Montrof
0
 
gowflowCommented:
ok last question
How do we name the workbooks and we save them I presume in same directory as the current file.
gowflow
0
 
montrofAuthor Commented:
That would work for me.

Thanks,
Montrof
0
 
gowflowCommented:
yes but you did not answer first part

"How do we name them"

gowflow
0
 
montrofAuthor Commented:
Oh sorry just name the same as the base sheet name,  like Sheet1, Sheet2, Sheet3, and SheetA

montrof
0
 
NorieVBA ExpertCommented:
montrof

Are 'Sheet1', 'Sheet2', etc the real names of the sheets you are working with?
0
 
montrofAuthor Commented:
Thank you so much!!!
0
 
gowflowCommented:
Your welcome
gowflow
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.