代码之家 › 专栏 › 技术社区 › alex2002

vba循环检查不同列中的类似值

excel excel-vba vba

alex2002 · 技术社区 · 6 年前

代码检查第2、4、6、8、10和11列,看它们是否在单元格中输入了类似的值。例如,如果第2、4、6、8、10和11列中的第4行和第5行都插入了类似的值,则会检查第15列,查看第4行和第5行中的值是否等于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

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

1 回复 | 直到 6 年前

MichaÅ Turczyn 6 年前

然后检查 .

我解释的功能是分组的概念,因此宏的名称:)

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