Excel VBA: Delete and Merge Sheets

[MLCR]

Hi, I am a beginner in Excel VBA.

When I download an Excel report from my accounting system, it generates 2 extra empty sheets called "Sheet2" and "Sheet3". I only need "Sheet1". This repeats for all other 10 reports that I download from the system. What I need to do is to delete "Sheet2" and "Sheet3" from every downloaded report and combine these 10 reports into a single workbook. I have managed to find this merging workbooks VBA (see below). But am wondering how can I add in the step to delete "Sheet2" and "Sheet3"?

Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "DesktopTest"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

I am open to other VBA code as well. Thanks!!

 

[drsarao]

No need to delete. Just DON'T copy them into your consolidated workbook. (You don't need the downloaded file anymore I presume)

Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "DesktopTest"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        If Sheet.Name <> "Sheet2" And Sheet.Name <> "Sheet3" Then
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
        End If
    Next Sheet
    Workbooks(Filename).Close
    Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

 

[MLCR]

It works! Thank you so much, really appreciate it!

Is it possible to include in VBA code different names for "Sheet1"?

Because when I do it manually, I will rename "Sheet1" to "ALI Aug20" and then remove "Sheet2" and "Sheet3".

On another report, I will rename the "Sheet1" to "PO Aug20" and remove the other 2 sheets.

In total, would have 10 of these to rename.

 

[drsarao]

Try this:

Sub ConslidateWorkbooks()

Dim FolderPath As String

Dim Filename As String

Dim pfx() As String, sfx As String

Dim Sheet As Worksheet

Application.ScreenUpdating = False

FolderPath = Environ("userprofile") & "DesktopTest"

Filename = Dir(FolderPath & "*.xls*")

pfx = Array("PO", "ALI", "xx", "xxx", "yyy") 'array for prefixes - as needed

sfx = "Aug20" 'suffix

p = 1

Do While Filename <> ""

    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True

    For Each Sheet In ActiveWorkbook.Sheets

        If Sheet.Name <> "Sheet2" And Sheet.Name <> "Sheet3" Then

            Sheet.Name = pfx(p) & sfx

            Sheet.Copy After:=ThisWorkbook.Sheets(1)

            p = p + 1

        End If

    Next Sheet

    Workbooks(Filename).Close

    Filename = Dir()

Loop

Application.ScreenUpdating = True

End Sub

populate pfx array as per your requirement for 10 sheets
I havent tested the code.
possible errors:
Excel doesn't tolerate duplicate sheet names.
pfx array should have enough (10) names or out of subscript error

 

[MLCR]

Ok, will try, thank you!

 

[MLCR]

Hi @drsarao, I'm facing the "run-time error '13': type mismatch error" when I added in the lines of codes for pfx and sfx.

Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim pfx() As String, sfx As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "DesktopTest"
Filename = Dir(FolderPath & "*.xls*")
pfx = Array("ALI", "Program-1", "Program-2", "Program-3", "PO", "Notes") 'array for prefixes - as needed
sfx = "Aug20" 'suffix
p = 1
Do While Filename <> ""
    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        If Sheet.Name <> "Sheet2" And Sheet.Name <> "Sheet3" Then
            Sheet.Name = pfx(p) & sfx
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
            p = p + 1
        End If

    Next Sheet
    Workbooks(Filename).Close
    Filename = Dir()
Loop

Application.ScreenUpdating = True

End Sub

I checked and the error occurs because of incompatible data types? Thank you!

 

[drsarao]

Dim pfx() without type declaration solves it. It actually declares the array as variant. And allows to store strings. Go figure.
Counter p has to start at 0 because this is 0 based array (Unless you declared "Option Base 1")

Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim pfx(), sfx As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = Environ("userprofile") & "DesktopTest"
Filename = Dir(FolderPath & "*.xls*")
pfx = Array("ALI", "Program-1", "Program-2", "Program-3", "PO", "Notes") 'array for prefixes - as needed
sfx = "Aug20" 'suffix
p = 0
Do While Filename <> ""
    Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        If Sheet.Name <> "Sheet2" And Sheet.Name <> "Sheet3" Then
            Sheet.Name = pfx(p) & sfx
            Sheet.Copy After:=ThisWorkbook.Sheets(1)
            p = p + 1
        End If
    Next Sheet
    Workbooks(Filename).Close
    Filename = Dir()
Loop

Application.ScreenUpdating = True

End Sub

Instead of hard coding pfx and sfx, you can pick them off the master worksheet.
eg
pfx=worksheets("Master").Range("Z1:Z10")
sfx=worksheets("Master").Range("Y1")

 

[MLCR]

Alright, thank you for your help! @drsarao

 

[drsarao]

You are welcome!