使用列标题将数据从一个工作簿复制到另一个工作簿

Question

有没有人有一段代码可以根据列标题从一个 excel WB 复制到另一个？

更新： 对不起，我是这个网站的新手，希望你能原谅我的无知。

这是我根据其他人的帖子尝试过的代码（谢谢你，Simon！）。

Sub copy_cols()

    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)

For Each rgCell In SourceWS.Range("A1:AX1")

TargetWS.Columns(GetColumn(TargetWS, rgCell.Value)) = _
 SourceWS.Columns(GetColumn(SourceWS, rgCell.Value))
' I Have also tried this with no success:
' TargetWS.Columns(GetColumn(TargetWS, rgCell.Value)) = _
 SourceWS.Columns(GetColumn(SourceWS, rgCell.Column))

End Sub

Function GetColumn(GCSheet As Worksheet, ColumnName As String) As Integer
    Dim intCol As Integer

    On Error Resume Next
    intCol = Application.WorksheetFunction.Match(ColumnName, GCSheet.Rows(1), 0)
    If Err.Number <> 0 Then
        GetColumn = 0
    Else
        GetColumn = intCol
    End If
End Function

我在 TargetWS.Cells 的第一行和第 5 行（不包括计数时的空格）收到错误“ByRef 参数类型不匹配”......

我也有这个......它有效，但我必须添加一堆 .End(xlDown) 来解决丢失的信息，以便复制整个列（不仅仅是复制到下一个有值的单元格）。你有更好的系统来解决这个问题吗？

Sub CopyHeaders()
    Dim header As Range, headers As Range

    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)

    Set headers = SourceWS.Range("A1:AX1")

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
           Range(header.Offset(1, 0), header.End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown)).Copy Destination:=TargetWS.Cells(2, GetHeaderColumn(header.Value)) '.End(xlDown).Offset(1, 0)
        End If
    Next

如您所见，我必须为每个空白单元格添加 .End(xlDown)。提前感谢您提供的任何帮助。

Answer 1

以下代码应该可以根据您的需要进行更改...

Sub CopyByHeader()

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer

    SourceWS.Activate            
    For Each Cell In TargetHeader
        SourceCol = SourceWS.Rows(SourceHeaderRow).Find _
            (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Column
        If SourceCol <> 0 Then
            RealLastRow = SourceWS.Columns(SourceCol).Find("*", LookIn:=xlValues, _
                 SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            SourceWS.Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                  SourceCol)).Copy
            TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
        End If
    Next

End Sub

更新：一些错误的标题不在源表或空列中。 还值得注意的是，使用此代码 - 您必须打开“Source.xlsx”才能从中读取。

更新代码：

Sub CopyByHeader()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer

    SourceWS.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                        SourceCol)).Copy
                    TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next

    CurrentWS.Activate

End Sub

Answer 2

Function GetColumn(GCSheet As Worksheet, ColumnName As String) As Integer
    Dim intCol As Integer

    On Error Resume Next
    intCol = Application.WorksheetFunction.Match(ColumnName, GCSheet.Rows(1), 0)
    If Err.Number <> 0 Then
        GetColumn = 0
    Else
        GetColumn = intCol
    End If
End Function

将其用于您的源工作表和目标。您也可以使用“查找”。这假设您的列在第 1 行。

那么这只是一种情况

wsDestination.cells(intDestRow, GetColumn(wsDestination, "ColumnName")).value = _
    wsSource.cells(intSourceRow,GetColumn(wsSource, "ColumnName")).value