CODEWITHSUNDEEP
excelvbacopyheading
VBAWARD
VBAWARD

Reputation: 71

VBA - Copy column values from multiple sheets based on column headings.

I'm still new to VBA and I'm a bit lost on how to solve this particular issue.

I have several worksheets within 1 workbook. The goal is to copy data from each worksheet based on the column headings, since not all of the column headings are uniform across all sheets.

For ex:

The Master Sheet has 6 column headings which I'd like to pull.

Sheet 1 has 8 column headings, the values for some columns within this are blank.

Sheet 2 has 7 column headings.

Sheet 3 has 10 column headings, etc.

My goal is to go to each sheet, have it loop through each column heading and copy/paste the data into the Master sheet if the column heading matches.

I don't know how to get it to look for the last row and copy the whole column based on the heading.

An example of code I've pieced together below:

Sub MasterCombine()

Worksheets("Master").Activate

Dim ws As Worksheet
Set TH = Range("A1:F1")

For Each ws In ActiveWorkbook.Worksheets

    If ws.Name <> "Master" And ws.Range("A8").Value <> "" Then
    ws.Select

    Range("A8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Worksheets("Master").Activate



For Each cell In TH

If cell.Value = "Subject" Then

cell.EntireColumn.Copy


End If

The problem with the above is that it copies the entire range but doesn't filter out column headings that aren't in the Master sheet.

Any help would be appreciated.

Upvotes: 0

Views: 1831

Answers (1)

urdearboy
urdearboy

Reputation: 14590

This might work. Loading your Master headers into an array. Then looping through each ws - then looping through your headers array. 

Option Explicit

Sub MasterMine()

Dim Master As Worksheet: Set Master = ThisWorkbook.Sheets("Master")
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet, Found As Range, i As Long, Arr

LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value

For Each ws In Worksheets
    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i, 1), LookIn:=xlWhole)
            If Not Found Is Nothing Then
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
            End If
    Next i
Next ws

End Sub

Upvotes: 0

Related Questions