Question

我正在尝试编写一个宏，它会根据列标题将数据从一个工作表复制到另一个工作表。让我们说在ws1中有三列：“产品”，“名称”，“雇主”和ws2：“产品”，“名称”，“区域”。

所以我希望宏执行所有复制，因为在我的原始文件中我有超过100个列标题，这将是非常耗时的自己做。

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

这是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

这个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

我的代码很乱，但如果你想让我提供更多细节留下评论，我不指望你给出一个完全可行的代码，一个很好的解释，很少有建议。感谢

Answer 1

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

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

这将无论列顺序。您可以更改范围引用以适应。

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

Answer 2

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

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

2 个答案: