Question

我有以下VBA代码，它匹配2个工作表之间的列数据，我遇到的问题是它在粘贴时会覆盖数据。

xlUP通过代码不起作用，即使使用不同的代码，我似乎无法修复它。

任何人都可以提供帮助。

Sub copyDataBlocks2()
Dim intErrCount As Integer

' create worksheet objects
Dim shtSource As Worksheet: Set shtSource = Sheets("ws2")
Dim shtTarget As Worksheet: Set shtTarget = Sheets("ws1")

' create range objects
Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:BB1")

With shtTarget
    Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:AB1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AB1")
    Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1 + 1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With

Dim rngDataColumn As Range

' process data
Dim cl As Range, i As Integer
For Each cl In rngTargetHeaders ' loop through each cell in target header row

    ' identify source location
    i = 0 ' reset I
    On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
        i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
    On Error GoTo 0 ' switch error handling back off

    ' report if source location not found
    If i = 0 Then
        intErrCount = intErrCount + 1
        Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
        GoTo nextCL
    End If

    ' create source data range object
    With rngSourceHeaders.Cells(1, i)
        Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
    End With

    ' pass to target range object
    cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

nextCL:
Next cl

' confirm process completion and issue any warnings
If intErrCount = 0 Then
    MsgBox "process completed", vbInformation
Else
    MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
End If
End Sub

VBA - 匹配列数据和粘贴

0 个答案: