CODEWITHSUNDEEP
excelvba
CESBoston
CESBoston

Reputation: 83

VBA code to copy column from Excel based on header name to another sheet

I am trying to create an Excel Macro using VBA to copy entire columns based on the column heading to an Excel sheet. So far, my code works when the column heading is located in the first row of the sheet, but if I alter HeaderRow_A = 5 and SourceDataStart = 6 for a sheet where the column headings are on the fifth row instead of the first, the first column copies over as expected, but the other columns do not. I need some code revisions that will allow all the desired columns to be copied over from Sheet A to Sheet B. Here is the specific area where I am encountering the issue: 

With ws_A
SourceDataStart = 6
HeaderRow_A = 5  'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column  'Get number of NAMEs you have

Here is the entire code for your reference: 

Sub RetrieveData()

Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet

Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant

Dim i As Long

Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long

Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")

With ws_A
    SourceDataStart = 6
    HeaderRow_A = 5  'set the header row in sheet A
    TableColStart_A = 1 'Set start col in sheet A
    HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column  'Get number of NAMEs you have

    For i = TableColStart_A To HeaderLastColumn_A
        If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then  'check if the name exists in the dictionary
             NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
        End If
    Next i

End With



With ws_B  'worksheet you want to paste data into
    ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
    For i = 1 To ws_B_lastCol   'for each data
        SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))  'get the column where the name is in Sheet A from the dictionaary

        If SourceCol_A <> 0 Then  'if 0 means the name doesnt exists
            SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
            Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
            NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A

            .Range(.Cells(NextEntryline, i), _
                   .Cells(NextEntryline, i)) _
                   .Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
        End If

    Next i
End With


End Sub

Upvotes: 0

Views: 2628

Answers (1)

dasche
dasche

Reputation: 111

I see two conflicting definitions of where the headers are located on sheet B.

This snippet is saying that your Sheet B headers are on the same row as Sheet A

ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column

And this snippet says that they are on row 1

SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))

I imagine this is where the issue lies.

Upvotes: 1

Related Questions