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

 

[mumps]

We would have to know the names of the sheets which contain relevant data and if the these sheet names are the same in all the workbooks. Also, it would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of at least 2 or three of your sheets. Alternately, you could upload a copy of 2 or 3 of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[vbanewbie365]

We would have to know the names of the sheets which contain relevant data and if the these sheet names are the same in all the workbooks. Also, it would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of at least 2 or three of your sheets. Alternately, you could upload a copy of 2 or 3 of your files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

So lets say my sheet names are just 'Property', "Vehicle' and 'Flood'. The sheet names are consistent across all workbooks. In all sheets the existing headers are in row 1 as per the original macro. So I just need to include the sheet names in the code somehow rather than all sheets as there are some sheets with names like 'title' and 'index' that contain irrelevant data in row 1 (and throughout the sheet) that is messing up the outcome of the original macro.

 

[mumps]

Could you follow the instructions I described to add screen shots or upload the files? This makes it easier to test any possible solution.

 

[vbanewbie365]

Could you follow the instructions I described to add screen shots or upload the files? This makes it easier to test any possible solution.

Hi there, no problem! I've created a dummy sheet but this is essentially what my data file looks like:

mrexcel.xlsx

Shared with Dropbox

www.dropbox.com

 

[mumps]

The three sheets you mentioned have a different number of columns. Will those columns always be in the same order in all the workbooks? I assume that you just want to copy the data from each sheet to the destination sheet, each sheet's data under the other. Is this correct?

 

[mumps]

Will the Index sheet always contain the names of the relevant sheets?

 

[vbanewbie365]

The three sheets you mentioned have a different number of columns. Will those columns always be in the same order in all the workbooks? I assume that you just want to copy the data from each sheet to the destination sheet, each sheet's data under the other. Is this correct?

So the original code takes into account that different sheets will have different number of columns, while some are the same. The output is a new table on a new sheet which contains all possible headers (without duplicates). The columns will always be in the same order across all workbooks. And yes, I want to copy the data from each sheet to the destination sheet under each other.

 

[vbanewbie365]

Will the Index sheet always contain the names of the relevant sheets?

No, so the index sheet will contain names of relevant sheets, but will also contain different and irrelevant text across different workbooks. Ideally I dont want the code to use the index page in terms of finding sheet names - I'm happy to just manually enter them into the code.

 

[mumps]

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