Question

在尝试执行初始比较后，我试图两次比较数据。我已经使用了多个宏，这些宏已由主宏调用以执行此方法，但是我仍然遇到问题。

当我将B和G列与E列进行比较时，开始第一个初始比较。（图1）然后B列中的所有剩余数据开始在Z列中形成一个列表，而G列中的剩余数据开始形成a中的列表。列在AJ列中（图2）。

我的问题是我想从Z和AJ列中剪切数据，并将它们添加回B和G列中，同时通过比较这两列仍然保持相同的组成格式。如果它们不匹配，我想创建一个新行并相应地粘贴这些数据。

我的第一个宏粘贴在这里，彼此分别被调用，

Sub MatchNSortO()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet1").Range("B18:C999").Cut
ThisWorkbook.Sheets("Sheet1").Range("AB18").Select
ActiveSheet.Paste 'Originals Column

ThisWorkbook.Sheets("Sheet1").Range("G18:H999").Cut
ThisWorkbook.Sheets("Sheet1").Range("AG18").Select
ActiveSheet.Paste 'Working Column
SendKeys ("{ESC}")
Application.ScreenUpdating = True




For r = 18 To Cells(Rows.Count, "E").End(xlUp).row     ' From row 1 to the 
last row with data
On Error Resume Next

myCountif = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")
myLookup = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")

MyAnswer = 
Application.WorksheetFunction.Application.Countif(Range("AB18:AB999"), 
Cells(r, "E"))

If MyAnswer = 1 Then
Match = Application.WorksheetFunction.Application.VLookup(myLookup, 
ThisWorkbook.Sheets("Sheet1").Range("AB18:AB999"), 1, 0)
Cells(r, "B").Value = Match
myFiletype = ThisWorkbook.Sheets("Sheet1").Cells(r, "B")
FileExt = Application.WorksheetFunction.Application.VLookup(myFiletype, 
ThisWorkbook.Sheets("Sheet1").Range("AB18:AC999"), 2)
Cells(r, "C").Value = FileExt
ElseIf MyAnswer = 0 Then
Cells(r, "B").Value = ""

End If
Next r
Call CompareOriginal
Call MatchNSortW
Call CompareWorking
End Sub

Sub CompareOriginal()

Dim i As Long, arrB As Variant, arrAB As Variant, z As Object, rng As Range
Set z = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False

Dim NextRow As Range
Set NextRow = Sheet1.Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0)

 With Worksheets("sheet1")

    arrB = .Range(.Cells(18, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
    arrAB = .Range(.Cells(18, "AB"), .Cells(.Rows.Count, 
   "AB").End(xlUp)).Value

    For i = LBound(arrAB, 1) To UBound(arrAB, 1)
        If arrAB(i, 1) <> vbNullString Then
            If IsError(Application.Match(arrAB(i, 1), arrB, 0)) Then
                z.Item(arrAB(i, 1)) = vbNullString
            End If
        End If
    Next i

    .Cells(18, "Z").Resize(z.Count, 1) = Application.Transpose(z.keys)
    'Sheets(1).Range("Z18:Z999").Copy

    'Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Select
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Interior.Color = vbGreen
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Value = "Drawings Not 
     Found In ECM Spreadsheet"
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, 0).Select

    '.Cells(18, "Z").Resize(z.Count, 1) = Application.Transpose(z.keys)
    'Sheets(1).Range("Z18:Z999").Cut
    'ActiveSheet.Paste
    'For Each rng In Selection

     '   rng.Offset(0, 1) = Application.WorksheetFunction.VLookup(rng, 
     Range("AB18:AB999"), 2)

    '    If IsEmpty(Cells(rng, "B")) Then Exit For
    'Next rng


End With
'Sheets("Sheet1").Range("Z18:AC999").ClearContents
End Sub

Sub MatchNSortW()

On Error Resume Next
For r = 18 To Range("E" & Rows.Count).End(xlUp).row ' From row 1 to the last 
row with data
On Error Resume Next

myCountif = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")
myLookup = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")

MyAnswer = 
Application.WorksheetFunction.Application.Countif(Range("AG18:AG999"), 
Cells(r, "E"))
Cells(r, "G").Value = MyAnswer

If MyAnswer = 1 Then
MyAnswer = Application.WorksheetFunction.Application.VLookup(myLookup, 
ThisWorkbook.Sheets("Sheet1").Range("AG18:AG999"), 1, 0)
Cells(r, "G").Value = MyAnswer
myFiletype = ThisWorkbook.Sheets("Sheet1").Cells(r, "G")
FileExt = Application.WorksheetFunction.Application.VLookup(myFiletype, 
ThisWorkbook.Sheets("Sheet1").Range("AG18:AH999"), 2)
Cells(r, "H").Value = FileExt
ElseIf MyAnswer = 0 Then
Cells(r, "G").Value = ""

End If


 Next r

 'Sheets("Sheet1").Range("AG18:AH999").ClearContents

   End Sub

 Sub CompareWorking()

Dim i As Long, arrB As Variant, arrAB As Variant, z As Object
Set z = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False

Dim NextRow As Range
Set NextRow = Sheet1.Cells(Cells.Rows.Count, 5).End(xlUp).Offset(1, 0)

With Worksheets("sheet1")

    arrB = .Range(.Cells(18, "G"), .Cells(.Rows.Count, "G").End(xlUp)).Value
    arrAB = .Range(.Cells(18, "AG"), .Cells(.Rows.Count, 
 "AG").End(xlUp)).Value

    For i = LBound(arrAB, 1) To UBound(arrAB, 1)
        If arrAB(i, 1) <> vbNullString Then
            If IsError(Application.Match(arrAB(i, 1), arrB, 0)) Then
                z.Item(arrAB(i, 1)) = vbNullString
            End If
        End If
    Next i

    .Cells(18, "AJ").Resize(z.Count, 1) = Application.Transpose(z.keys)

End With
'Sheets("Sheet1").Range("AG18:AH999").ClearContents
 End Sub

在复制和粘贴后尝试使用VLookup匹配数据

0 个答案: