VBA loop checking similar values in different columns

Question

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

You tried to explain how the code does it, but what is code meant to do? What is the reason for the code? What sort of values are being checked? What if row 6 and row 10 and row 13 are all similar? And how similar is similar? What if the columns are longer than a 1000 rows? Or shorter than a 1000 rows? Do you have Option Explicit? Why are all the declarations on a single row so they cannot be easily read? What do the variables mean? — AJD
– AJD, Commented Jun 18, 2018 at 7:17
Oh, and what have you done to try and solve your question yourself? Is it present in that code? Or is that code the original code (it smells) and you are looking for someone to add it for you? — AJD
– AJD, Commented Jun 18, 2018 at 7:21
Yes, i do have Option Explicit as well set. The reason of the code is to make sure that every time when similar values are inserted in i.e. rows 6, 10, 13, 15, 100 for columns 2, 4, 6, 8, 10 and 11 the sum of those rows in column 15 must always equal to 20. I will try to add one example in the description of the code. — alex2002
– alex2002, Commented Jun 18, 2018 at 7:23
As I mentioned in the beginning of the code, this was done with another user help as it was too complicated for me to do it by myself. Henceforth, I just added small parts to it in order to adjusted to my needs. — alex2002
– alex2002, Commented Jun 18, 2018 at 7:26
OK, the reasoning behind the code still is not clear - I am trying to determine if you are using a complex answer to a potentially simple problem (an X-Y problem). Can you create a helper column? And what sort of data is in the columns - because I can see some potential problems depending on the data. — AJD
– AJD, Commented Jun 18, 2018 at 7:29

Michał Turczyn · Accepted Answer · 2018-06-18 11:05:15Z

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

Thanks for helping in editing the description of the task and also for the code provided. I can see while testing the code that if the value is other than 20, it colors all the row(s). What I need to be colored are only the cell(s) from column 15 that don't equal to 20, so not the full row. Thanks
ohh, that was easy to go. Many thanks. The only I did it was to add an Else conditional formatting at the end after the user re-checks the mistake. Really appreciate your help!

Collectives™ on Stack Overflow

VBA loop checking similar values in different columns

1 Answer 1

2 Comments

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Related