VBA循环检查不同列中的相似值

Question

下面编写的 VBA 代码是由来自 stackoverflow 的用户完成的，但不幸的是，我再也找不到指向该代码的链接了。

代码检查第 2、4、6、8、10 和 11 列，看看它们是否在单元格中输入了相似的值。例如，如果第 2、4、6、8、10 和 11 列中的第 4 行和第 5 行都插入了相似的值，它会检查第 15 列以查看第 4 行和第 5 行的值是否等于 20（可以输入的最大值）。如果没有，那么你会得到一个错误。否则，一切都好。

其次，我要补充的是，当第 4 行和第 5 行的值不相等时，第 4 行和第 5 行的第 15 列中的数字需要为 20。我在下面设置了一个示例，说明如何输入可能会在 Excel 中查找。

总体而言，如果上述列中的值不相似，则第 15 列中插入的数字需要始终为 20。否则，当列插入相似值时，它们的总和需要等于 20。感谢您的帮助！

---

很好的例子：这就是代码现在所做的。

    2       4     6      8      10       11      15 

4   home    US    dog    car    plate    food    16   
5   home    US    dog    car    plate    food    3
20  home    US    dog    car    plate    food    1

---

---

这就是我现在要实现的代码：

    2       4     6      8      10       11          15 

4   home    US    dog    car    plate    food        20   
5   home    US    dog    car    plate    tv          20
20  home    US    dog    car    plate    kitchen20   20

这里每一行都是不同的，因此，每行需要在第 15 列中有值 20。

---

Private Sub CommandButton1_Click()

Dim iz As Long, jz As Long, sum1 As Long, kz As Long, c(1000) As Long, fl(1000) As Boolean, b As Boolean, sum2 As Long

Application.ScreenUpdating = False


    Dim s1 As String, s2 As String
    Range("a4:a1000").Interior.Color = RGB(255, 255, 255)
    For iz = 4 To 999
        kz = 0
        s1 = Cells(iz, 2) & Cells(iz, 4) & Cells(iz, 6) & Cells(iz, 10) & Cells(iz, 11)
        If s1 <> "" Then
            If Not fl(iz) Then
                For jz = iz + 1 To 1000
                    If Not fl(jz) Then
                        s2 = Cells(jz, 2) & Cells(jz, 4) & Cells(jz, 6) & Cells(jz, 10) & Cells(jz, 11)
                        If s2 <> "" Then
                            If s1 = s2 Then
                                If kz = 0 Then sum1 = Cells(iz, 15): kz = 1: c(kz) = iz: fl(iz) = True
                                sum2 = sum1 + Cells(jz, 15)
                                kz = kz + 1
                                c(kz) = jz
                                fl(jz) = True
                            End If
                        End If
                    End If
                Next jz
                If sum2 <> 20 Then
                    For jz = 1 To kz
                        Cells(c(jz), 15).Interior.Color = RGB(255, 0, 0)
                        b = True
                    Next jz

                ElseIf sum2 = 20 Then
                        For jz = 1 To kz
                    Cells(c(jz), 40).Value = 1
                    Next jz


                End If
            End If
        End If


    Next iz



If b Then MsgBox "The values don't equal 20%." & Chr(10) & _
                        "Make the changes an try again!", vbInformation, "IMPORTANT:" Else MsgBox "No errors found!", vbInformation, "IMPORTANT:"



Application.ScreenUpdating = True


End Sub

Answer 1

试试下面的代码。

为了运行此代码，您需要在您的 VBE 中进入 Tools -> References... 并检查 Microsoft Scripting Runtime。

使用 Dictionary，整个任务变得简单，不需要您提供复杂的代码。它将所有单元格（第 15 列除外）视为键。每个键从第 15 列中获取所有对应值，在第一个循环中求和。在第二个循环中，您检查与键对应的值是否等于 20，如果不是，则将行涂成红色（或在该情况下执行其他操作）。

我解释的功能是分组的想法，因此是宏的名称:)

Option Explicit
Sub GroupBy()

    Dim lastRow As Long, i As Long, dict As Scripting.Dictionary, key As String
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Set dict = New Scripting.Dictionary

    For i = 1 To lastRow
        key = Cells(i, 2) & Cells(i, 4) & Cells(i, 6) & Cells(i, 8) & Cells(i, 10) & Cells(i, 11)

        If dict.Exists(key) Then
            dict(key) = dict(key) + Cells(i, 15)
        Else
            dict.Add key, CInt(Cells(i, 15))
        End If
    Next

    For i = 1 To lastRow
        key = Cells(i, 2) & Cells(i, 4) & Cells(i, 6) & Cells(i, 8) & Cells(i, 10) & Cells(i, 11)
        'if value is other than 20, color the row with red
        If dict(key) <> 20 Then Cells(i, 15).Interior.ColorIndex = 3
    Next

End Sub