Simplify Code

P

peerogel

Board Regular
Joined
Jan 25, 2011
Messages
108
Could I please get help simplifying (if possible) the message box.
Currently, the message box pops at the end of the code and displays the following when it finds a duplicate in a row between range B and K.

cell.address and cell.value
cell.address and cell.value

And repeats any duplicate values underneath in a single message box.

I'm trying to get it to display
"Repeat Dates found in rows" & vbNewline &_
row.address cell.value - cell.value" & vbNewLine

Thanks in advance for any help.

Code: 
Sub test1()
    Dim Counter As Integer
    Dim Msg As String
Application.ScreenUpdating = False
    For Counter = 6 To 300
    
        bValue = ActiveSheet.Cells(Counter, 2)
        cValue = ActiveSheet.Cells(Counter, 3)
        dValue = ActiveSheet.Cells(Counter, 4)
        eValue = ActiveSheet.Cells(Counter, 5)
        fValue = ActiveSheet.Cells(Counter, 6)
        gValue = ActiveSheet.Cells(Counter, 7)
        hValue = ActiveSheet.Cells(Counter, 8)
        iValue = ActiveSheet.Cells(Counter, 9)
        jValue = ActiveSheet.Cells(Counter, 10)
        kValue = ActiveSheet.Cells(Counter, 11)
        
        
       
        
        For Each cl In ActiveSheet.Cells(Counter, 2)
        If bValue = dValue And bValue <> "" Then
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
                    End If
        
        If bValue = fValue And bValue <> "" Then
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If bValue = hValue And bValue <> "" Then
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
                
        If bValue = jValue And bValue <> "" Then
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        Next cl
        
        
        
        '''''''''' B----D---F-----H-----J---
        For Each cl In ActiveSheet.Cells(Counter, 4)
        If dValue = bValue And dValue <> "" Then
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If dValue = fValue And dValue <> "" Then
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
            
        If dValue = hValue And dValue <> "" Then
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If dValue = jValue And dValue <> "" Then
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        Next cl
        
        
        
'''''''''' B----D---F-----H-----J---
        For Each cl In ActiveSheet.Cells(Counter, 6)
        If fValue = bValue And fValue <> "" Then
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If fValue = dValue And fValue <> "" Then
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If fValue = hValue And fValue <> "" Then
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If fValue = jValue And fValue <> "" Then
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        Next cl
'''''''''' B----D---F-----H-----J---
        For Each cl In ActiveSheet.Cells(Counter, 8)
        If hValue = bValue And hValue <> "" Then
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If hValue = dValue And hValue <> "" Then
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If hValue = fValue And hValue <> "" Then
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If hValue = jValue And hValue <> "" Then
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        Next cl
        
        '''''''''' B----D---F-----H-----J---
        For Each cl In ActiveSheet.Cells(Counter, 10)
        If jValue = bValue And jValue <> "" Then
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 2).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 3).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If jValue = dValue And jValue <> "" Then
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 4).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 5).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If jValue = fValue And jValue <> "" Then
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 6).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 7).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        'MsgBox Cell_Values
        End If
        
        If jValue = hValue And jValue <> "" Then
            ActiveSheet.Cells(Counter, 10).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 11).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 8).Interior.Color = RGB(255, 10, 10)
            ActiveSheet.Cells(Counter, 9).Interior.Color = RGB(255, 10, 10)
        Cell_Values = Cell_Values & vbNewLine & cl.Address(False, False) & " - " & cl.Value
        MsgBox Cell_Values
        End If
                    If Msg <> "" Then
                    Msg = Cell_Values
                    Else
                    Msg = "test"
                    End If
        Next cl
        
        
    Next
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
A simple example

Code: 
Sub FileSelectionExample()
    Dim I As Long
    Dim cl As Range
    Dim Cell_Values As Variant
    Dim Title As String


    Title = "Date Check"
    Cell_Values = "Repeat Dates found in rows:" & vbNewLine
    Set cl = ActiveCell
    For I = 0 To 5
        With cl.Offset(I)
            Cell_Values = Cell_Values & vbNewLine & "Row " & .Row & ", Cell " & .Address(False, False) & " -> " & .Value
        End With
    Next I


    MsgBox Cell_Values, vbOKOnly + vbInformation, Title
End Sub
 
Upvote 0
Thanks for the quick reply. I'm trying to figure out the code. What is the 0 to 5 used for? I can't get it to find the duplicates I need. The duplicates are per row not per column. I'm trying to figure out what rows have duplicates entries. To be more specific, Column B is a starting date Column C is an ending Date and so forth with the following Columns D/E, F/G, H/I, J/K. I want the message box to tell me the row the duplicate is in the starting date and ending date. Thanks once more. I'll see if I can figure out the offset.
 
Upvote 0
How about
Code: 
Sub test1()
    Dim i As Long, j As Long, k As Long
    Dim Msg As String
Application.ScreenUpdating = False
    
   For i = 6 To Range("B" & Rows.Count).End(xlUp).Row
      For j = 2 To 10 Step 2
         For k = j To 10 Step 2
            If Not Cells(i, k) = "" And Not Cells(i, k).Address = Cells(i, j).Address Then
               If Cells(i, k) = Cells(i, j) Then
                  Union(Cells(i, k).Resize(, 2), Cells(i, j).Resize(, 2)).Interior.Color = vbRed
                  Msg = Msg & vbLf & Cells(i, j).Address(False, False) & "-" & Cells(i, k).Address(False, False) & "-" & Cells(i, k).Value
               End If
            End If
         Next k
      Next j
   Next i
   If Not Len(Msg) = 0 Then MsgBox Msg

Application.ScreenUpdating = True
End Sub
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Tab Selection from Userform based on Date range
Replies
5
Views
134
campbell1093
C
A
  • Question Question
VBA Highlight cell if contains specific text
Replies
4
Views
2K
DanteAmor
DanteAmor
R
  • Question Question
CELL FILL COLOR NOT HOLDING ON WORKSHEET
Replies
1
Views
320
Joe4
Joe4
R
  • Question Question
Search a range for a specific color of rows, relocate those cells to another sheet, return previous sheet formatting to blank and sort secondary sheet
Replies
4
Views
360
Royalbloodi
R
H
  • Question Question
Add a criteria to VBA Code
Replies
8
Views
365
hrayani
H

Forum statistics

Threads
1,223,893
Messages
6,175,248
Members
452,623
Latest member
cliftonhandyman

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top