CODEWITHSUNDEEP
vbaexcel
alex2002
alex2002

Reputation: 161

VBA loop checking similar values in different columns

The VBA code written below is done with a user from stackoverflow, but unfortunatly I cannot find anymore the link to that.

The code checks the columns 2, 4, 6, 8, 10 and 11 to see if they have similar values entered into the cells. For example, if row 4 and 5 in columns 2, 4, 6, 8, 10 and 11 have all inserted similar values, it checks column 15 to see if the values from row4 and 5 equal 20 (the max value that can be entered). If it doesn't then you get an error. Otherwise, all good.

Second, the thing I want to add is that when the values are not equal in row 4 and 5, the number in column 15 needs to be 20 for both row 4 and 5. I set an example below on how the entries might look in Excel.

Overall, the number inserted in column 15 needs always to be 20 if the values are not similar in the columns mentioned above. Otherwise, when the columns have similar values inserted, the sum of them needs to equal to 20. Thanks for helping out!

Good example: This is what the code does now.

    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

This is what I want to be implemented to the code now: 

    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

Here each row is different, henceforth, each row needs to have the value 20 in column 15.

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

Upvotes: 1

Views: 190

Answers (1)

Michał Turczyn
Michał Turczyn

Reputation: 37500

Try below code.

In order to run this code, you need to go in your VBE to Tools -> References... and check Microsoft Scripting Runtime.

With Dictionary, whole task becomes simple and doesn't require complicated code you provided. It treats all cells (except column 15) as key. Every key gets all corresponding values from column 15 summed in first loop. In second loop, you check if value corresponding to the key is equal to 20 and if not, color the row red (or do other operations on that occasion).

The functionality I explained is the idea of grouping by, thus the name of a macro :)

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

Upvotes: 1

Related Questions