VBA通过标题名称复制列并粘贴到另一个工作簿中

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

它有效，但是有两个我不知道的问题：

1）如何将第2行中的列复制到最后一行？我的目标单元格中​​有标题。

2）我的VBA基于对每一列重复相同的代码位。是否可以通过这样的方式修改它，即可以在顶部定义源列名称和目标列范围，并在循环中运行相同的代码。我不知道如何编写这样的代码，但是我有30多个列，并且将代码复制30次似乎是浪费...

还有一个好处：我的代码将数据复制到每一列的最后使用的行。但是，某些列的确包含空白单元格。这不是什么大问题，但是是否可以为所有要复制的列设置“最后一行范围”以成为A列的最后一行？此列保存所有50000个单元格中的数据。

Answer 1

用您的列名ColumnNameList = Array("id", "sisteprosess", "hendelse")定义一个数组，然后遍历它。您还需要一个计数器PasteColumn才能移至下一列以粘贴到数据工作表中。

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

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, SourceWS.Cells(lastRow, FoundAt.Column)).Copy Destination:=TargetWS.Cells(1, PasteColumn)
                PasteColumn = PasteColumn + 1 'move to next paste column
            End If
        End With
    Next ColumnName
End Sub