Excel VBA macro for consolidating data from multiple sheets based on sheet names with specific text

Question

I have an Excel workbook that has the potential for a large number of sheets to be added in or removed. Each of these will have a standard suffix, let's call this ".A"

What I would like is a macro that for each worksheet with this suffix, copies all data from a selected range on each worksheet (say:A1:X50), copies it to a new consolidated worksheet, moves to the next line on the consolidated sheet and repeats for each subsequent worksheet. So far, I have this... but it doesn't work.

 Sub compile()
SelectSheets ".A", ThisWorkbook
 'Some other bits and pieces here
End Sub


Sub SelectSheets(sht As String, Optional wbk As Workbook)

Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long

If wbk Is Nothing Then Set wbk = ActiveWorkbook

ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
    If InStr(1, wks.Name, sht) > 0 Then
        ArrWks(i) = wks.Name
        i = i + 1
    End If
Next wks
ReDim Preserve ArrWks(i - 1)
Sheets(ArrWks).Select

For Each ws In Sheets(ArrWks)

            ws.Range("D36:CT46").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
            Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Have you debugged this code? How do the intermediate variable values differ from what you expect? At what point do this happen? — halfer

QHarr QHarr · Accepted Answer · 2018-01-03T11:40:55

There are other changes i would make to this code but the basics are as follows; where you loop the array containing the worksheet names and do your copying.

Note:

1) You are picking up any worksheet name with .A in, not just those with it as a suffix.

2) You might also want some error handling in case no sheets are found as then your array will end up throwing an out of bounds error.

3) Your first paste will be to row 2 if you don't test if last row = 1.

Looping of array:

 For ws = LBound(ArrWks) To UBound(ArrWks)

A test for the suffix might better be

If Right$(wks.Name, 2) = ".A" Then

Code:

Option Explicit

Sub compile()

  SelectSheets ".A", ThisWorkbook
 'Some other bits and pieces here

End Sub


Sub SelectSheets(sht As String, Optional wbk As Workbook)

Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long

If wbk Is Nothing Then Set wbk = ActiveWorkbook

ReDim ArrWks(0 To Worksheets.Count - 1)

For Each wks In Worksheets

    If InStr(1, wks.Name, sht) > 0 Then
        ArrWks(i) = wks.Name
        i = i + 1
    End If

Next wks

ReDim Preserve ArrWks(i - 1)

Dim ws As Long

For ws = LBound(ArrWks) To UBound(ArrWks)

    Worksheets(ArrWks(ws)).Range("D36:CT46").Copy
    Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)

Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Excel VBA macro for consolidating data from multiple sheets based on sheet names with specific text

1 Answers