How to search specific sheets in a merging table macro

[vbanewbie365]

Hi friends,

So P45Cal helpfully posted some code that merged tables across several sheets and workbooks into a master table. the code read as below. As a VBA noob, I'm wondering how to adjust the code to only search specific sheets rather than all sheets. To be specific in my workbooks, I have several sheets which contain non-relevant information to the destination table, but the code currently searches all sheets and thus includes these title sheets. How can i specify the code to search only sheets that I choose, ideally by searching by sheet name as I'm not too confident in indexing the sheets etc. Any help is much appreciated!

Sub blah()
Dim rngHdr As Range, HdrsToCopy As Range, DestRow As Range
Dim AllHeaders()
ReDim AllHeaders(0 To 0)
With ThisWorkbook
  Set DestSheet = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With  'thisworkbook
With DestSheet
  Set DestRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)  'or any other column.
End With  'DestSheet
filenames = Application.GetOpenFilename("Excel files,*.xls*", MultiSelect:=True)
If IsArray(filenames) Then
  For Each fName In filenames
    Set WkBk = Workbooks.Open(fName)
    For Each sht In WkBk.Sheets
      rowscount = sht.UsedRange.Rows.Count - 1
      For Each cll In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
        NewHeader = False
        HeaderColumn = 0
        For i = LBound(AllHeaders) To UBound(AllHeaders)
          If AllHeaders(i) = cll.Value Then
            HeaderColumn = i
            Exit For
          End If
        Next i
        If HeaderColumn = 0 Then
          If UBound(AllHeaders) = 0 Then ReDim AllHeaders(1 To UBound(AllHeaders) + 1) Else ReDim Preserve AllHeaders(1 To UBound(AllHeaders) + 1)
          AllHeaders(UBound(AllHeaders)) = cll.Value
          HeaderColumn = UBound(AllHeaders)
          NewHeader = True
        End If
        If NewHeader Then DestSheet.Cells(1, HeaderColumn).Value = AllHeaders(HeaderColumn)
        cll.Offset(1).Resize(rowscount).copy DestRow.Offset(, HeaderColumn - 1)
      Next cll
      Set DestRow = DestRow.Offset(rowscount)
    Next sht
    WkBk.Close False
  Next fName
End If
End Sub

 

[vbanewbie365]

Untested.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsArr As Variant, i As Long, desWS As Worksheet, fLcol As Long, lCol As Long, lRow As Long, filenames, WB As Workbook
    wsArr = Array("Vehicle", "Property", "Flood")
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Merged Data"
    Set desWS = ThisWorkbook.Sheets("Merged Data")
    filenames = Application.GetOpenFilename("Excel files,*.xls*", MultiSelect:=True)
    If IsArray(filenames) Then
        For Each fname In filenames
            Set WB = Workbooks.Open(fname)
            For i = LBound(wsArr) To UBound(wsArr)
                If i = 0 Then
                    With ActiveWorkbook.Sheets(wsArr(i))
                        .UsedRange.Copy desWS.Range("A1")
                        fLcol = desWS.Cells(1, .Columns.Count).End(xlToLeft).Column
                    End With
                Else
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                        If lCol <= fLcol Then
                            .UsedRange.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                        Else
                            desWS.Cells(1, fLcol + 1).Resize(, lCol - fLcol).Value = .Cells(1, fLcol + 1).Resize(, lCol - fLcol).Value
                            .UsedRange.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                            fLcol = desWS.Cells(1, .Columns.Count).End(xlToLeft).Column
                        End If
                    End With
                End If
            Next i
            ActiveWorkbook.Close False
        Next fname
    End If
    Application.ScreenUpdating = True
End Sub

Thank you! Will give this a try later on. If I change the row where data is in the reference sheets, would I change the line below to reflect the new row? Reason being that I suspect I may add some preamble above the data tables across the workbook in a consistent manner. Such that all headers may start in row 10 across all sheets.

.UsedRange.Copy desWS.Range("A1")

 

[vbanewbie365]

Thank you! Will give this a try later on. If I change the row where data is in the reference sheets, would I change the line below to reflect the new row? Reason being that I suspect I may add some preamble above the data tables across the workbook in a consistent manner. Such that all headers may start in row 10 across all sheets.

Also - what do u think of the original code that P45Col provided that I included in the original post. I was quite keen to continue using that as the code ran as I understood most of it quite well (not well enough to make the changes I want though haha). Would there be an easy way within that original code to select specific sheets? I tried messing around with the For loop in the line below, but kept producing errors as I dont think I was accounting for it correctly across the entire block of code.

For Each sht In WkBk.Sheets

 

[mumps]

If you change the row where data is in the reference sheets, it would require several changes in the code. Let me know of any changes and I will modify the code. The code I suggested loops only through the workbooks that are opened, not through the cells and headers and this speeds things up. All you have to do is add sheet names to the array in the code when necessary.

 

[vbanewbie365]

If you change the row where data is in the reference sheets, it would require several changes in the code. Let me know of any changes and I will modify the code. The code I suggested loops only through the workbooks that are opened, not through the cells and headers and this speeds things up. All you have to do is add sheet names to the array in the code when necessary.

I'm thinking I'll likely have headers starting at row 16 across all sheets to give me some leeway to include some title/preamble/branding. thank you! You're a legend.

edit: The resultant table on the new sheet can start in row 1 however, i think thats fine and easier to use later on

 

[mumps]

I'll get back to you.

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsArr As Variant, i As Long, desWS As Worksheet, fLcol As Long, lCol As Long, lRow As Long, filenames, WB As Workbook
    wsArr = Array("Vehicle", "Property", "Flood")
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Merged Data"
    Set desWS = ThisWorkbook.Sheets("Merged Data")
    filenames = Application.GetOpenFilename("Excel files,*.xls*", MultiSelect:=True)
    If IsArray(filenames) Then
        For Each fname In filenames
            Set WB = Workbooks.Open(fname)
            For i = LBound(wsArr) To UBound(wsArr)
                If i = 0 Then
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        .Range("A16:A" & lRow).Resize(, lCol).Copy desWS.Range("A1")
                        fLcol = desWS.Cells(1, .Columns.Count).End(xlToLeft).Column
                    End With
                Else
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        If lCol <= fLcol Then
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                        Else
                            desWS.Cells(1, fLcol + 1).Resize(, lCol - fLcol).Value = .Cells(16, fLcol + 1).Resize(, lCol - fLcol).Value
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                            fLcol = desWS.Cells(16, .Columns.Count).End(xlToLeft).Column
                        End If
                    End With
                End If
            Next i
            ActiveWorkbook.Close False
        Next fname
    End If
    desWS.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[vbanewbie365]

Thanks - I seem to be having trouble running this, and no new sheet is created. Does your code allow for extra sheets (to be searched)? I've added extra sheets alongside flood, property etc but noting it doesnt create a new sheet

 

[mumps]

If you add additional sheets to this line of code, they will also be searched:

wsArr = Array("Vehicle", "Property", "Flood")

Please post the code that you revised.

 

[vbanewbie365]

I've added 2 new sheets, binders and commercial. Wondering how to allow the code to take into account that I may be adding extra sheets (consistent across all workbooks), but this has not been finalized that yet. any help is much appreciated!

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsArr As Variant, i As Long, desWS As Worksheet, fLcol As Long, lCol As Long, lRow As Long, filenames, WB As Workbook
    wsArr = Array("Vehicle", "Property", "Flood","Binders","Commercial")
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Merged Data"
    Set desWS = ThisWorkbook.Sheets("Merged Data")
    filenames = Application.GetOpenFilename("Excel files,*.xls*", MultiSelect:=True)
    If IsArray(filenames) Then
        For Each fname In filenames
            Set WB = Workbooks.Open(fname)
            For i = LBound(wsArr) To UBound(wsArr)
                If i = 0 Then
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        .Range("A16:A" & lRow).Resize(, lCol).Copy desWS.Range("A1")
                        fLcol = desWS.Cells(1, .Columns.Count).End(xlToLeft).Column
                    End With
                Else
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        If lCol <= fLcol Then
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                        Else
                            desWS.Cells(1, fLcol + 1).Resize(, lCol - fLcol).Value = .Cells(16, fLcol + 1).Resize(, lCol - fLcol).Value
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                            fLcol = desWS.Cells(16, .Columns.Count).End(xlToLeft).Column
                        End If
                    End With
                End If
            Next i
            ActiveWorkbook.Close False
        Next fname
    End If
    desWS.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[mumps]

allow the code to take into account that I may be adding extra sheets

The code should do that as written. If it's not working for you, please upload a copy of the file that is not working properly.