使用列标题将数据从一个工作簿复制到另一个工作簿 [英] Copy Data from One workbook to another using column header

问题描述

是否有任何一个代码从一个excel WB复制到另一个基于列标题的代码？

Does any one have a piece of code to copy from one excel WB to another based on column headers?

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

Update: Sorry to all, I am new to this site and I hope you can forgive my ignorance.

以下是我尝试过的代码，基于其他人的帖子（谢谢，Simon！）。

Here is the code I have tried, based on other's posts (thank you, 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参数类型不匹配。

I am getting an error "ByRef argument type mismatch" on the first and 5th line (excluding the spaces when count) at TargetWS.Cells....

我也有这个...这是有效的，但是我必须添加一堆.End（xlDown）来记录缺少的信息，所以整个列被复制（不只是下一个单元格带有一个值）。你有更好的系统来解决这个问题吗？

I also have this... which works, but I have to add in a bunch of .End(xlDown)'s to account for missing information so the whole column is copied (not just to the next cell WITH a value). Do you have a better system to account for this?

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）对于每个空白单元格。提前感谢您可以提供的任何帮助。

As you can see, I have to add in .End(xlDown) for every blank cell. Thanks in advance for any assistance you can offer.

推荐答案

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

The following code should be able to be altered to suit your needs...

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才能读取。

UPDATE: Some errors with headers not in source sheet or empty columns. It's also worth noting that with this code - you have to have 'Source.xlsx' open to read from it.

更新的代码：

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

这篇关于使用列标题将数据从一个工作簿复制到另一个工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！