宏 VBA 复制基于 Header 的列并粘贴到另一个 Sheet

Question

背景：这是我第一次接触宏。我将使用两个作品sheet。第一个 sheet，‘Source’ 将有数据可用。第二个 sheet，“Final”将是空白的，它将成为宏粘贴我希望它从“Source”sheet.

收集的数据的地方

* 我希望宏在“来源”sheet 中找到指定的 header，将包含 header 的单元格一直复制到现有数据的最后一行（而不是整列），并将其粘贴到指定列（A、B、C 等）中的“Final”sheet。 *

我必须指定要查找的 header 的原因是因为“来源”sheet 中的 header 并不总是位于同一位置，但是“Final”sheet 的 headers 将始终处于相同位置——所以我不能只记录复制“Source”sheet 中 A 列并粘贴到列中的宏“决赛”中的 A sheet。此外，有一天“源”sheet 可能有 170 行数据，另一天可能有 180 行。

不过，最好复制整列，因为其中一列会有一些空单元格，而不是复制到现有数据的最后一行。我假设它会在到达所选列中的第一个空单元格时停止复制，这将遗漏该列中该空单元格之后的剩余数据——如果我错了请纠正我。如果复制整个列是最好的方法，那么请将其作为可能解决方案的一部分提供。我附上了一个我想要完成的前后结果的例子： Example of Result

找到 Header=X，复制整列 -> 粘贴到“Final”中的 A1 sheet

找到 Header=Y，复制整列 -> 粘贴到“Final”中的 B1 sheet

等等

如果我的措辞不准确，我深表歉意——我已尽力解释。如果有人可以帮助我解决这个问题，那就太棒了！谢谢！

Answer 1

你可以试试这个。我认为它清晰且循序渐进。它可以非常优化，但从 vba 开始，我认为这样更好。

两张表中的列名称必须相同。

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

祝你好运

Answer 2

我修改了我给另一个用户的答案，对你的情况有类似的问题，我在我的大部分数据表中都使用字典函数，这样我就可以在不破坏代码的情况下移动列，下面的代码可以移动你的列，它仍然可以工作

唯一的主要限制是 1. 你的 header 名字必须是唯一的 2. 您感兴趣的 header 名称必须完全相同。即，您感兴趣的来源 header 是 PETER，那么您的数据 table 应该与 PETER 有一个 header，并且它必须是唯一的。

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

宏 VBA 复制基于 Header 的列并粘贴到另一个 Sheet

Macro VBA to Copy Column based on Header and Paste into another Sheet

excel

vba

copy-paste