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的第一行和第五行（不包括计数时的空格）收到错误“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

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

将其用于源工作表和目的地。您也可以使用＆＃34;查找＆＃34;。假设您的列位于第1行。

然后它只是

的情况

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

Answer 2

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

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

更新：标题不在源表或空列中的一些错误。值得注意的是，使用此代码 - 您必须拥有＆＃39; Source.xlsx＆＃39;愿意阅读它。

更新代码：

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

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

2 个答案: