Код VBA для копирования столбца из Excel на основе имени заголовка на другой лист

Question

Я пытаюсь создать макрос Excel, используя VBA, чтобы скопировать все столбцы на основе заголовка столбца в лист Excel.Пока что мой код работает, когда заголовок столбца находится в первой строке листа, но если я изменю HeaderRow_A = 5 и SourceDataStart = 6 для листа, где заголовки столбцов находятся в пятом ряду вместо первого, первыйстолбцы копируются как положено, а остальные столбцы - нет.Мне нужны некоторые ревизии кода, которые позволят скопировать все нужные столбцы с листа A на лист B. Вот конкретная область, где я сталкиваюсь с проблемой:

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

Вот весь код дляВаша ссылка:

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

Answer 1

Я вижу два противоречивых определения расположения заголовков на листе B.

В этом фрагменте говорится, что ваши заголовки листа B находятся в одном ряду с листом A

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

И этот фрагмент говорит, что они находятся в ряду 1

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

Я думаю, что именно в этом заключается проблема.