比较两个工作簿 - 删除匹配的行 - 从 wkb 2 添加值到 wkb 1，其中差异

如何解决比较两个工作簿 - 删除匹配的行 - 从 wkb 2 添加值到 wkb 1，其中差异

希望你能帮我把不同的部分放在一起。

我有两本工作簿，wkbPB（基础），wkbZLISTP（与 wkbPB 比较）。两个工作簿都有两列包含文章编号。和标价。我需要比较每个货号的标价。在 wkbPB 中，带有该商品编号的标价。在 wkbZLISTP 中。

第 1 条中有匹配项的地方。且标价差小于 0.04 删除 wkbPB 中的行。
第 1 条中有匹配项的地方。且标价差大于0.04wkbZLISTP的标价需要写在wkbPB标价旁边的一栏中。
如果商品编号中没有匹配项，则在 wkbPB 中以红色显示的标价旁边的附加列中会写入“MISSING”。

目前我正在使用包含查找对话框的 For Next 循环执行此任务。它可以解决问题，但最多需要 45 分钟才能完成。现在我在互联网上搜索并通过似乎闪电般快速的数组进行了比较。 Example。

但是，我无法坚持如何根据我的目的自定义该代码，完全大脑冻结。你能帮忙吗？

非常感谢！

Dim d As Long
For d = 2 To noOfRowsPB Step 1
    If wkbPB.Worksheets(1).Cells(d,1).Value <> "" Then
        Dim looking4 As String
        looking4 = UCase(wkbPB.Worksheets(1).Cells(d,26).Value)
        Dim ctrUPNRng As Range
        Dim ctrUPNRow As Long
        Set ctrUPNRng = wkbZLISTP.Worksheets(1).Cells.Find(looking4,After:=Range("A1"),LookIn:=xlFormulas,LookAt _
            :=xlWhole,SearchOrder:=xlByRows,SearchDirection:=xlNext,MatchCase:=False,SearchFormat:=False)
        If Not ctrUPNRng Is nothing Then
            ctrUPNRow = ctrUPNRng.Row
            If Abs(CSng(wkbPB.Worksheets(1).Cells(d,24).Value) - CSng(wkbZLISTP.Worksheets(1).Cells(ctrUPNRow,14).Value)) > 0.04 Then
                wkbPB.Worksheets(1).Cells(d,27).Value = wkbZLISTP.Worksheets(1).Cells(ctrUPNRow,14).Value
            Else
                 Rows(d).EntireRow.Delete Shift:=xlUp
                 d = d - 1
            End If
        Else
            wkbPB.Worksheets(1).Cells(d,27).Value = "MISSING"
            With wkbPB.Worksheets(1).Range("AA" & d).Font
                .Color = -16776961
                .TintAndShade = 0
            End With
        End If
    Else
        Exit For
    End If
Next d

解决方法

花了一段时间，但我已经设法让它自己工作了！

我所需要的只是将数组的正确图片放入我的脑海中！这实际上非常简单：数组只不过是一个表。因此，您从工作表中获取数据范围并将该范围分配给数组！大功告成！

嗯，还有一些挑战需要克服，但有了这些基本的了解，我就成功了！

看看节省的时间：旧宏：33:43 分钟，新宏：7:31 分钟！

这就是现在的样子：

Dim d As Long
Dim PBArray As Variant
Dim ZLISTPArray As Variant
Dim f As Long
Dim rngPB As Range
Dim rngZLISTP As Range
Dim rowDel As Long
noOfRowsPB = wkbPB.Worksheets(1).Cells(Rows.Count,1).End(xlUp).Row
noOfRowsZLISTP = wkbZLISTP.Worksheets(1).Cells(Rows.Count,1).End(xlUp).Row
Set rngPB = wkbPB.Worksheets(1).Range(Cells(2,1),Cells(noOfRowsPB,26))
PBArray = rngPB
wkbZLISTP.Activate
Set rngZLISTP = wkbZLISTP.Worksheets(1).Range(Cells(2,Cells(noOfRowsZLISTP,19))
ZLISTPArray = rngZLISTP

rowDel = 0
For d = 1 To UBound(PBArray)
    For f = 1 To UBound(ZLISTPArray)
        'Can we find it?
        If PBArray(d,26) = ZLISTPArray(f,19) Then
            'Found it,now price comparison
            If Abs(PBArray(d,24) - ZLISTPArray(f,14)) > 0.04 Then
               'Price difference,we want to see it
               wkbPB.Worksheets(1).Cells(d + 1 - rowDel,27).Value = wkbZLISTP.Worksheets(1).Cells(f + 1,14).Value
               Exit For
            Else
                'No price difference,we can delete it
                wkbPB.Worksheets(1).Rows(d + 1 - rowDel).EntireRow.Delete Shift:=xlUp
                rowDel = rowDel + 1
                Exit For
            End If
        ElseIf f = UBound(ZLISTPArray) Then
            'Despite searching to the end,no findings,then we need to make that visible too
            wkbPB.Worksheets(1).Cells(d + 1 - rowDel,27).Value = "MISSING"
            With wkbPB.Worksheets(1).Range("AA" & d + 1 - rowDel).Font
                .Color = -16776961
                .TintAndShade = 0
            End With
        End If
    Next f
Next d

也许有一天这也会对某人有所帮助！

享受吧！