按 header 个名称复制列并粘贴到另一个工作簿

Question

得到这个 VBA 以按列名从源中复制选定的列：

Sub CopyColumnsByName()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range, sRange As Range, Rng As Range

    Dim TWS As ThisWorkbook
    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer


'COPY AND PASTE COLUMNS

'Column: id
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="id", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("A1").PasteSpecial
        End If
    End With


'Column: sisteprosess
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="sisteprosess", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("B1").PasteSpecial
        End If
    End With


'Column: hendelse
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="hendelse", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("C1").PasteSpecial
        End If
    End With


End Sub

有效，但有两个问题我想不通：

如何将第 2 行的列复制到最后一行？ Headers 已经在我的目标单元格中了。
我的 VBA 是基于对每一列重复相同的代码。是否可以通过这样一种方式修改它，即我可以在顶部定义源列名称和目标列范围，并在循环中定义运行相同的代码。我不知道怎么写这样的代码，但是我有30+列，复制代码30次似乎很浪费...

作为奖励：我的代码将数据复制到每一列的最后使用的行。但是，某些列确实有空白单元格。这不是什么大问题，但是是否可以将要复制的所有列设置为 "last row range" 为 A 列的最后一行？此列包含所有 50000 个单元格中的数据。

Answer 1

用您的列名ColumnNameList = Array("id", "sisteprosess", "hendelse")定义一个数组，然后遍历它。

您还需要一个计数器 PasteColumn 才能移动到下一列以粘贴到数据工作表中。请注意，这将从数据工作表的 A 列开始，然后粘贴到 B、C、...。

也不要使用 .Activate，因为您已经将工作表设置为变量 SourceWS 和 TargetWS 您可以在不激活 dirccy 的情况下使用它们。

您可以使用 .Offset(RowOffset:=1) 从找到的 header 向下移动一行，以便它从第 2 行开始仅复制数据（没有 header）。

Option Explicit

Public Sub CopyColumnsByName()   
    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")

'COPY AND PASTE COLUMNS
    Dim LastRowA As Long  'last row in col A (use for all copy actions)
    LastRowA = SourceWS.Cells(SourceWS.Rows.Count, "A").End(xlUp).Row

    Dim LastCol As Long   'last column for search
    LastCol = SourceWS.Cells(1, SourceWS.Columns.Count).End(xlToLeft).Column

    Dim SearchRange As Range  'define search range for column name
    Set SearchRange = SourceWS.Range("A1", SourceWS.Cells(1, LastCol))

    Dim ColumnNameList() As Variant
    ColumnNameList = Array("id", "sisteprosess", "hendelse")  'your columns list

    Dim PasteColumn As Long
    PasteColumn = 1 'start pasting in column 1 of your data worksheet

    Dim ColumnName As Variant
    For Each ColumnName In ColumnNameList
        With SearchRange
            Dim FoundAt As Range
            Set FoundAt = .Find(What:=ColumnName, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not FoundAt Is Nothing Then
                SourceWS.Range(FoundAt.Offset(RowOffset:=1), SourceWS.Cells(LastRowA, FoundAt.Column)).Copy Destination:=TargetWS.Cells(2, PasteColumn)
                PasteColumn = PasteColumn + 1 'move to next paste column
            End If
        End With
    Next ColumnName
End Sub

请注意，此处的列列表 ColumnNameList = Array("id", "sisteprosess", "hendelse") 是硬编码的。如果您已经将它们放在目的地，您可以更好地从那里阅读它们，而不是将它们写入您的代码。

ColumnNameList = TargetWS.Range("A1", TargetWS.Cells(1, TargetWS.Columns.Count).End(xlToLeft)).Value

按 header 个名称复制列并粘贴到另一个工作簿

Copy columns by header names and paste to another workbook

excel

vba

copy-paste