-2

我在编写用于比较多张工作表（同一个 Excel 文件）中的多列的宏时遇到问题。我写的很少，但他们花了很长时间，以至于 excel 崩溃了。

假设我在同一个文件中有 4 张纸。Sheet1 有两列（B 和 C）和 7000 行。Sheet2 空工作表新条目。Sheet3 旧条目的空白表，但有一些更新的值/信息。Sheet4 是一个有 2 列（A 和 B）和 22000 行的数据库。

我需要将 Sheet1 中的 A 列与 Sheet4 中的 B 列进行比较。如果 A 列 sheet1 中有全新的条目，则将该条目从 A 列 sheet1（及其相应值从 B 列 sheet1）复制到 Sheet2 中的新行（A 列和 B 列）。如果 A 列 Sheet1 中的条目已经在 A 列 sheet4 中，则比较它们各自的 B 列值。如果 Sheet 1 中的 A 列 + B 列组合在 Sheet4 中，则忽略它。如果 A 列 Sheet1 中的值位于 A 列 Sheet4 中，但它们各自的 B 列值不匹配，则将 Sheet1 中的 A 列 + B 列复制到 Sheet3 中的新行（A 列和 B 列）。

我希望它足够清楚。由于行数（Sheet1 中的 7000 与 Sheet4 中的 20000 相比），我无法编写一个在一分钟内处理所有内容的宏。

有什么帮助吗？

编辑1：我使用了@FaneDuru 建议的代码（谢谢！）。但我遇到一个错误：“运行时错误'457'：此键已与此集合的元素相关联”是因为我在同一列中有许多重复值吗？

编辑 2：似乎 VBA 无法识别“if not dict3.exists”代码。当我用小写字母键入“.exists”并跳转到另一行时，应该将其更正为大写“.Exists”，对吗？它没有这样做。

编辑3：我做了更多测试。我正在休息并运行代码。当我在这一行“If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then”上放置中断时，不会发生错误。当我将中断放在“For j = UBound(arr4) To 1 Step -1”下面的一行时，错误正在发生。

错误是：“运行时错误'457'：此键已与此集合的元素相关联”

Private Sub CommandButton1_Click()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim arr1, arr2, arr3, arr4, dict2 As Object, dict3 As Object, rngA4 As Range
Dim rngB4 As Range, i As Long, j As Long, lastR1 As Long, lastR4 As Long

lastR1 = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
lastR4 = Sheet4.Range("A" & Sheet4.Rows.Count).End(xlUp).Row

Set rngA4 = Sheet4.Range("A2:A" & lastR4)
Set rngB4 = Sheet4.Range("B2:B" & lastR4)

arr1 = Sheet1.Range("B2:C" & lastR1).Value
arr4 = Sheet4.Range("A2:B" & lastR4).Value

Set dict2 = CreateObject("Scripting.Dictionary")
Set dict3 = CreateObject("Scripting.Dictionary")

For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4, arr1(i, 1)) = 0 Then
        dict2.Add arr1(i, 1), arr1(i, 2):
    End If
    If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i, 1) = arr4(j, 1) Then
                If arr1(i, 2) <> arr4(j, 2) Then
                    If arr1(i, 2) <> arr4(j, 2) Then
                        dict3.Add arr1(i, 1), arr1(i, 2): Exit For
                End If
            End If
        Next j
    End If
Next i

If dict2.Count > 0 Then
    arr2 = Application.Transpose(Array(dict2.keys, dict2.Items))
    Sheet2.Range("A2").Resize(dict2.Count, 2).Value = arr2
End If

If dict3.Count > 0 Then
    arr3 = Application.Transpose(Array(dict3.keys, dict3.Items))
    Sheet3.Range("A2").Resize(dict3.Count, 2).Value = arr3
End If

MsgBox "Done!"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub
4

2 回答 2

0

您可以使用 excel 公式 countif 来查找数据集中不存在的任何数据条目。

然后，您可以使用 Sheets().Range().Value = Sheets().Range().Value 在您想要输出的工作表中复制该值。如果输出范围已经填充，您可以使用 Sheets().Range().End(xlDown).Address 来查找输出数据集最后一行的地址。

您遍历每个返回 0 的 countif 值以获取所有丢失的数据。

于 2021-02-06T16:24:06.377 回答
0

请测试下一个代码。您没有回答澄清问题，并且代码假定出现的次数不超过一次，并且通过添加行来加载已处理的工作表。代码独立于这方面工作，但如果上面的假设是正确的，它会运行得更快：

Sub testProcessNewEntries()
 Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
 Dim arr1, arr2, arr3, arr4, dict2 As Object, dict3 As Object, rngA4 As Range
 Dim rngB4 As Range, i As Long, j As Long, lastR1 As Long, lastR4 As Long
 
 Set sh1 = Worksheets("Sheet1") 'use here your first sheet
 Set sh2 = Worksheets("Sheet2") 'use here your second sheet
 Set sh3 = Worksheets("Sheet3") 'use here your third sheet
 Set sh4 = Worksheets("Sheet4") 'use here your fourth sheet
 
 lastR1 = sh1.Range("A" & sh1.Rows.count).End(xlUp).row
 lastR4 = sh4.Range("A" & sh4.Rows.count).End(xlUp).row
  
 Set rngA4 = sh4.Range("A2:A" & lastR4)
 Set rngB4 = sh4.Range("B2:B" & lastR4)
 
 arr1 = sh1.Range("A2:B" & lastR1).Value
 arr4 = sh4.Range("A2:B" & lastR4).Value
 
 Set dict2 = CreateObject("Scripting.Dictionary")
 Set dict3 = CreateObject("Scripting.Dictionary")
 
 For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4, arr1(i, 1)) = 0 Then
        dict2.Add arr1(i, 1), arr1(i, 2):
    End If
    If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i, 1) = arr4(j, 1) Then
                If arr1(i, 2) <> arr4(j, 2) Then
                    If Not dict3.Exists(arr1(i, 1)) Then
                        dict3.Add arr1(i, 1), arr1(i, 2): Exit For
                    End If
                End If
            End If
        Next j
    End If
 Next i
 
 If dict2.count > 0 Then
    arr2 = Application.Transpose(Array(dict2.Keys, dict2.Items))
    sh2.Range("A2").Resize(dict2.count, 2).Value = arr2
 End If
 If dict3.count > 0 Then
    arr3 = Application.Transpose(Array(dict3.Keys, dict3.Items))
    sh3.Range("A2").Resize(dict3.count, 2).Value = arr3
 End If
 MsgBox "Ready..."
End Sub
于 2021-02-06T18:24:54.893 回答