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

Question

Справочная информация: я впервые работаю с макросами. У меня будет две таблицы, которые я буду использовать. На первом листе «Источник» будут доступны данные. Второй лист, «Final», будет пустым и будет там, где макрос будет вставлять данные, которые я хотел бы получить из листа «Source».

* Я хочу, чтобы макрос нашел указанный заголовок на листе «Источник», скопировал эту ячейку, содержащую заголовок, вплоть до последней строки существующих данных (вместо всего столбца) и вставил это на «Финальный» лист в указанном столбце (A, B, C и т. д.). *

Причина, по которой я должен указать, какие заголовки нужно найти, заключается в том, что заголовки на листе «Источник» не всегда будут находиться в одной и той же позиции, а заголовки листа «Финал» всегда будут в одной и той же позиции, поэтому Я НЕ МОГУ ЗАПИСАТЬ макросы, копирующие столбец А на листе «Источник» и вставляющие в столбец А на листе «Финал». Кроме того, однажды на листе «Источник» может быть 170 строк данных, а в другой - 180 строк.

Хотя, вероятно, было бы лучше скопировать весь столбец, поскольку в одном из столбцов будет несколько пустых ячеек, а не последняя строка существующих данных. Я предполагаю, что он перестанет копировать, когда достигнет первой пустой ячейки в выбранном столбце, что оставит оставшиеся данные после этой пустой ячейки в столбце - исправьте меня, если я ошибаюсь. Если копирование всего столбца является наилучшим способом, укажите это как часть возможного решения. Я привел пример результата до и после, которого я хотел бы достичь: Пример результата

Найти верхний колонтитул = X, скопировать весь столбец -> Вставить в A1 на листе "Финал"

Найти заголовок = Y, скопировать весь столбец -> Вставить в B1 на «Финальном» листе

Etc ..

Извините, если моя формулировка не точна - я пытался объяснить как мог. Было бы здорово, если бы кто-то мог помочь мне в этом! Спасибо!

Answer 1

Я изменил ответ, который дал другому пользователю с похожей проблемой для вашего случая, Я использую функцию словаря в большинстве своих таблиц данных, так что я могу перемещать столбцы, не нарушая код, приведенный ниже код позволяет перемещать столбцы, и он все равно будет работать

единственное основное ограничение 1. Ваши заголовки должны быть уникальными 2. Ваше имя заголовка интереса должно быть точно таким же. т. е. ваш интересующий исходный заголовок - PETER, тогда ваша таблица данных должна иметь заголовок с PETER, и он должен быть уникальным.

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 = 2
    HeaderRow_A = 1  '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 2

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

имя столбца должно быть одинаковым на обоих листах.

Sub teste()

Dim val
 searchText = "TEXT TO SEARCH"

 Sheets("sheet1").Select ' origin sheet
 Range("A1").Select
 Range(Selection, Selection.End(xlToRight)).Select
 x = Selection.Columns.Count ' get number of columns

 For i = 1 To x 'iterate trough origin columns
  val = Cells(1, i).Value
    If val = searchText Then
        Cells(1, i).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("sheet2").Select  ' destination sheet
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        y = Selection.Columns.Count ' get number of columns

        For j = 1 To y 'iterate trough destination columns

          If Cells(1, j).Value = searchText Then
            Cells(1, j).Select
            ActiveSheet.Paste
            Exit Sub
          End If

       Next j
    End If
  Next i

End Sub

удачи