PDA

View Full Version : [SOLVED] Loop to match headers on separate sheets, copy and paste revisited



damius314
08-22-2018, 03:53 PM
I am trying to create a spreadsheet with my first tab being the "master sheet" with a varying number of column headers only. There will also be additional sheets in the workbook that have matching column headers with data below it. I would like to be able to search all the other pages, matching columns with the master sheet and pasting the data below the column headers on the master sheet. The code below seemed like it would do the trick, however, after spinning my wheels for hours, I am not able to figure out the error. I attempted to upload a sample file as an xlsx and xlsm and both failed. Any suggestions on why it wouldn't upload?

Thanks for the help.

Here is the code originally posted by SamT


Option Explicit
Sub VBAX_SamT()
'Adjust 2 instances "MasterSheetName" to suit
'For each header in Master Sheet, searches all other sheets for matching header,
'Then copys all data below matching header to bottom of Used Master header column.

Dim rngMasterHeaders As Range
Dim Cel As Range
Dim Sht As Worksheet
Dim CopyHeader As Range
Dim Dest As Range

Set rngMasterHeaders = Sheets("PBT"). _
Range(Cells(1, "A"), Cells(1, Columns.Count).End(xlToLeft))

For Each Cel In rngMasterHeaders
If Cel.Value <> "" Then
For Each Sht In Worksheets
If Sht.Name <> "PBT" Then
Set CopyHeader = Sht.Range("1:1").Find(Cel.Value)
If Not CopyHeader Is Nothing Then
Set Dest = Cel.Parent.Range(Rows.Count, Cel.Column).End(xlUp).Offset(1)
Range(CopyHeader.Offset(1), Cells(Rows.Count, CopyHeader.Column).End(xlUp)).Copy Dest
Set CopyHeader = Nothing
End If
End If
Next Sht
End If
Next Cel
End Sub

jolivanes
08-26-2018, 06:28 PM
Is this what you mean? Try on a copy of your original first.

Sub Maybe()
Dim sh1 As Worksheet, sht As Worksheet, c As Range, hdrCol As Long
Set sh1 = Worksheets("Master")
Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> "Master" Then
With sht
For Each c In .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column))
If WorksheetFunction.CountIf(sh1.Rows(1), c) <> 0 Then
hdrCol = sh1.Rows(1).Find(c, , , 1).Column
.Range(c.Offset(1), c.Offset(1).End(xlDown)).Copy sh1.Cells(Rows.Count, hdrCol).End(xlUp).Offset(1)
End If
Next c
End With
End If
Next sht
Application.ScreenUpdating = True
End Sub

damius314
10-02-2018, 01:41 PM
Sorry, it took so long to respond. Thank you, worked like a charm.:thumb

jolivanes
10-02-2018, 06:12 PM
Thank you for letting us know.
Good luck