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]

Apologies Mumps! It works!! I had an issue with data permissions as data was being pulled from some various sites but all works now. You're an absolute legend for all your help. Now on to the next challenge....

 

[vbanewbie365]

Hmm... actually having further issues. Some data is not being pulled through into the new mergeddata sheet. I'm noting this issue on sheets where there is data in the first row of the table (row 17), and in sheets where the first row is blank in some columns, but data is present in other sections. I think this problem is causing some of the headers to not pull through as well. Currently some of my data is drop down selection items, wondering if that has an impact? May be difficult to share the workbook as some confidential data, but could potentially anonymize.

Ideally, the code should basically append all these various tables together - and align data into the same columns in the new 'mergeddata' sheet where there headers match. Where a header is unique to one specific sheet, this should just create a new header all together similar to the original code from P45Col.

 

[vbanewbie365]

Hmm... actually having further issues. Some data is not being pulled through into the new mergeddata sheet. I'm noting this issue on sheets where there is data in the first row of the table (row 17), and in sheets where the first row is blank in some columns, but data is present in other sections. I think this problem is causing some of the headers to not pull through as well. Currently some of my data is drop down selection items, wondering if that has an impact? May be difficult to share the workbook as some confidential data, but could potentially anonymize.

Ideally, the code should basically append all these various tables together - and align data into the same columns in the new 'mergeddata' sheet where there headers match. Where a header is unique to one specific sheet, this should just create a new header all together similar to the original code from P45Col.

I have updated the dropbox file to represent these changes (minus the dropdown boxes as was having trouble converting). But essentially, I was hoping to see all the headers be pulled into the new sheet (minus duplicates) and all the line items where data is populated (even if some columns are blank etc) into their own rows.

mrexcel.xlsx

Shared with Dropbox

www.dropbox.com

 

[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, lRow2 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
                        lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        If lCol <= fLcol Then
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Range("A" & lRow2)
                        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.Range("A" & lRow2)
                            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]

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, lRow2 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
                        lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        If lCol <= fLcol Then
                            .Range("A17:A" & lRow).Resize(, lCol).Copy desWS.Range("A" & lRow2)
                        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.Range("A" & lRow2)
                            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

Thanks - I'm now pulling data from all the sheets, but its not aligning things to the correct headers on the merged data sheet - additionally, not all headers are pulling through. As column orders are not always consistent in the source sheets, I'm hoping to get the code to read the existing headers and pull them into the new sheet, preventing duplicates, and putting the data into the correct columns, either where they are consistent with existing columns in other sheets, or by creating a new header and column in the merged data sheet

 

[vbanewbie365]

Attached a screenshot here. As you can see in the new transmission type header, we're getting dates in that column. Additionally some of the headers from the 'Commercial' sheet' such as 'Business Type' and 'Structure' arent getting pulled through

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsArr As Variant, i As Long, ii As Long, desWS As Worksheet, fLcol As Long, lCol As Long, lCol2 As Long, lRow As Long, lRow2 As Long, filenames, WB As Workbook
    Dim v As Variant
    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, desWS.Columns.Count).End(xlToLeft).Column
                    End With
                Else
                    With ActiveWorkbook.Sheets(wsArr(i))
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        lCol = .Cells(16, .Columns.Count).End(xlToLeft).Column
                        v = .Range("B16").Resize(, lCol - 1).Value
                        For ii = LBound(v) To UBound(v, 2)
                            Set header = desWS.Rows(1).Find(v(1, ii), LookIn:=xlValues, lookat:=xlWhole)
                            If Not header Is Nothing Then
                                .Range(.Cells(17, ii + 1), .Cells(lRow, ii + 1)).Copy desWS.Cells(lRow2, header.Column)
                            Else
                                lCol2 = desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column + 1
                                .Cells(16, ii + 1).Copy desWS.Cells(1, lCol2)
                                .Range(.Cells(17, ii + 1), .Cells(lRow, ii + 1)).Copy desWS.Cells(lRow2, lCol2)
                            End If
                        Next ii
                    End With
                End If
            Next i
            ActiveWorkbook.Close False
        Next fname
    End If
    desWS.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[vbanewbie365]

Thanks - have tried but the resultant mergeddata sheet is now blank.

 

[mumps]

This is what I got when I ran the macro using the data in the file you posted:

Entity

Entity ID

Size

Transmission type

Model type

Transaction type

Date

Date closed

Date Archived

Registration

Frequency

Report (Y/N)

Identifier

Scope indicator

Area

Region

State

Event category

Business Type

Structure

Business B

5555​

Medium

Honda

Expense

2019-11-30​

2019-12-05​

2020-01-01​

Yes

Daily

Y

14.055.22

Scope 1

Expense

2019-01-01​

Open

Open

Expense

2019-01-02​

Open

Open

Expense

2019-01-03​

Open

Open

Business A

5555​

Claim

2022-12-30​

2023-01-04​

Yes

Daikly

Y

13.066.11

55.3​

West

Outer

WA

Entity

Entity ID

Transaction type

Date

Date closed

Date Archived

Registration

Frequency

Report (Y/N)

Event category

1234​

Property Val

5555​

Capital Acq

2019-11-30​

2019-12-05​

2020-01-01​

No

Weekly

N

55.312​

Scope 2

US Bank

5555​

20/06/2009

20/12/2021

Yes

Daily

Y

14.055.22

Scope 1

Durable goods

LLC

 

[vbanewbie365]

Ahhh ok - was running into some data permission issues again as some of the data is pulled from sharepoints etc and it wasnt being pulled through consistently. It is working like a charm now. Mumps you are a legend!