vba 根据列将数据从一个工作表复制到另一个工作表

Copy data from one worksheet to another based on column

提问by user2722393

I am trying to write a macro that will copy data from one worksheet to another based on column headers. Lets say in ws1 there are three columns: "product", "name", "employer" and the ws2: "product", "name", "region".

我正在尝试编写一个宏，它将根据列标题将数据从一个工作表复制到另一个工作表。假设在 ws1 中有三列：“product”、“name”、“employer”和 ws2：“product”、“name”、“region”。

So i want the macro to do all the copying as in my original file i have over 100 column headers and it will be very time consuming for to do it myself.

因此，我希望宏执行所有复制操作，就像在我的原始文件中一样，我有 100 多个列标题，而自己进行复制会非常耗时。

I have written two macros without succes. VBA is something I cant understand for quite some time. but still managed to write something, hope you can tell me if i am going in the right direction.

我写了两个宏没有成功。VBA 是我很长一段时间无法理解的东西。但仍然设法写了一些东西，希望你能告诉我我是否朝着正确的方向前进。

this is v1

这是 v1

Sub Copy_rangev1()

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SourceRange As Range, CopyRange As Range
Dim lastrow As Long
Dim i As Integer

Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Set Ws2 = ThisWorkbook.Worksheets("sheet2")

lastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1

Set SourceRange = Ws2.Range("A1").CurrentRegion
Set CopyRange = Ws1.Range("A1").CurrentRegion

For i = 1 To lastrow
    If SourceRange.Cells(i, 1).Value = CopyRange.Cells(i, 1) Then
       SourceRange.Cells(i + 1 & lastrow, 1).Copy Destination:=CopyRange.Range("a" & lastrow)
    End If
Next i

End Sub

this v2:

这个v2：

Sub Copyrangev2()

Dim SourceRange As Worksheet
Dim CopyRange As Worksheet
Dim lastrow As Integer
Set SourceRange = Worksheets("Sheet2")
Set CopyRange = ThisWorkbook.Worksheets("sheet1")
Dim i As Integer

lastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To 100
    If SourceRange.Range(1, i).Value = CopyRange.Range(1, i) Then
       SourceRange.Range(1, i).Offset(1, 0).Copy Destination:=CopyRange.Range(1, i)
    End If
Next i

End Sub

My code is a mess, but if you want me to provide any more details leave a comment, i dont expect you to given a fully workable code, a good explanation and few suggestions will do. Thanks

我的代码一团糟，但是如果您希望我提供更多详细信息，请留下评论，我不希望您提供完全可行的代码，一个很好的解释和很少的建议可以做到。谢谢

采纳答案by Alex P

How about this? This code works as follows

这个怎么样？这段代码的工作原理如下

• Iterate across each column header in ws1and see if a matching header exists in ws2
• If a match is found, copy the column contents across to the relevant column in ws2

• 遍历中的每个列标题ws1并查看其中是否存在匹配的标题ws2
• 如果找到匹配项，请将列内容复制到 ws2

This will work irrespectiveof column order. You can change the range references to suit.

无论列顺序如何，这都将起作用。您可以更改范围参考以适应。

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Set headers = Worksheets("ws1").Range("A1:Z1")

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

Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("ws2").Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

回答by Divakar

Sub CustomColumnCopy()

    Dim wsOrigin As Worksheet
    Dim wsDest As Worksheet
    Dim rngFnd As Range
    Dim rngDestSearch As Range
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim cel As Range
    Dim rownum As Range

    Set wsOrigin = Sheets("Sheet1")
    Set wsDest = Sheets("Sheet2")

    Const ORIGIN_ROW_HEADERS = 1
    Const DEST_ROW_HEADERS = 1

    If ActiveWorkbook.ProtectStructure = True Or _
       wsOrigin.UsedRange.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    For Each rownum In wsOrigin.UsedRange

        Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))

        For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
        On Error Resume Next

            Set rngFnd = rngDestSearch.Find(cel.Value)

            If Not rngFnd Is Nothing Then

               wsDest.Cells(rownum.Cells.row, rngFnd.Column).Value = wsOrigin.Cells(rownum.Cells.row, cel.Column).Value

            End If

        On Error GoTo 0

        Set rngFnd = Nothing

        Next cel

    Next rownum

    ActiveWindow.View = ViewMode
    Application.GoTo wsDest.Range("A1")
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

    Dim keyRange As Range

    Set keyRange = Range("A1")
    wsDest.Range("A" & LastRow(wsDest) + 1).Sort Key1:=keyRange, Header:=xlYes

End Sub