VBA Loop Gives Double Lines of Errors

O

OilEconomist

Active Member
Joined
Dec 26, 2016
Messages
439
Office Version
  1. 2019
Platform
  1. Windows
Thanks in advance for any suggestions for which feedback will be given.

This code runs through a series of tabs and wherever it sees an error, it takes that line and places it in the "Error.Items" sheet. Why is it duplicating each error? I guess I could write code at the end to remove the duplicate lines, but I would like to figure out what I am doing wrong. Also, some of the code I don't think I need so feel free to suggest. For example, is the following needed?

Code: 
If J = 1 Or J = 2 Or J = 6 Or J = 7 _
                        Or J = 8 Or J = 9 Or J = 10 Or J = 11 Or J = 12 _
                        Or J = 9 Or J = 10 Or J = 11 Or J = 12 Or J = 14 _
                        Or J = 15 Or J = 17 Or J = 19 Or J = 20 Or J = 21 _
                        Or J = 22 Or J = 23 Or J = 24 Or J = 27 _
                        Or J = 30 Or J = 31 Or J = 32 Or J = 33 Or J = 34 _
                        Or J = 35 Or J = 36 Or J = 37 Or J = 38 Or J = 39 _
                        Or J = 40 Then
                            'do nothing



The following is the entire code:

Code: 
Sub Error_Check()


'Turn off alerts, screen updates, and automatic calculation
        'Turn off Display Alerts
            Application.DisplayAlerts = False


        'Turn off Screen Update
            Application.ScreenUpdating = False


        'Turn off Automatic Calculations
            Application.Calculation = xlManual




'Dimensioning
    Dim LastRow As Long
    Dim Error_Row As Long
    Dim Error_Count As Long
    Dim Error_Count_Clm As Long
    Dim i As Long, J As Long, k As Long
    
    Dim X As Long




'Looping through all the tabs to find the errors
    Error_Row = 3
    
    For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name = "Error.Items" Or Sheet.Name = "JIBs.End" Then
            For X = Sheets("JIBs.End").Index - 1 To Sheets("Error.Items").Index + 1 Step -1


        'Find the last row of data
            Sheets(X).Activate
            
            LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row
            
            Error_Count = 0




            For i = 3 To LastRow
        
                Error_Count = 0
        
                For J = 1 To 41


                    If J = 1 Or J = 2 Or J = 6 Or J = 7 _
                        Or J = 8 Or J = 9 Or J = 10 Or J = 11 Or J = 12 _
                        Or J = 9 Or J = 10 Or J = 11 Or J = 12 Or J = 14 _
                        Or J = 15 Or J = 17 Or J = 19 Or J = 20 Or J = 21 _
                        Or J = 22 Or J = 23 Or J = 24 Or J = 27 _
                        Or J = 30 Or J = 31 Or J = 32 Or J = 33 Or J = 34 _
                        Or J = 35 Or J = 36 Or J = 37 Or J = 38 Or J = 39 _
                        Or J = 40 Then
                            'do nothing


                        ElseIf Cells(i, J) = "" And J = 3 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "No CC Xref" And J = 5 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf J = 5 Then
                            If Cells(i, J) = "" Or Cells(i, J) = "No CC Xref" Then
                                Cells(i, J).Font.Bold = True
                                Cells(i, J).Interior.ColorIndex = 3
                            End If
            
                        ElseIf J = 13 Then
                            If Cells(i, J) <> 1 And Cells(i, J) <> 3 Then
                                Cells(i, J).Font.Bold = True
                                Cells(i, J).Interior.ColorIndex = 3
                            End If
            
                        ElseIf Cells(i, J) = "" And J = 16 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                
                        ElseIf Cells(i, J) = "" And J = 18 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 26 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                    
                        ElseIf Cells(i, J) = "!Xref Error" And J = 28 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 29 And Cells(i, 25) <> "REVENUE" Then
                            Cells(i, 25).Font.Bold = True
                            Cells(i, 25).Interior.ColorIndex = 2
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 41 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                    
                    End If
            
                    'Count the number of errors in each row
                        If Cells(i, J).Font.Bold = True Then
                            Error_Count = Error_Count + 1
                        End If
                 
                Next J
            
                            
                'Designate the errors
                    If Error_Count > 1 Then
                        Range("AS" & i).Value = "Yes"
                        Range("AS" & i).Font.Bold = True
                        Range("AS" & i).Interior.ColorIndex = 3
                        
                        Range("AX" & i).Value = Error_Count
                                                
                        
                        'Indicate which errors are present
                        
                            Error_Count_Clm = Error_Count
                            
                            'Partner CC
                                If Range("E" & i).Font.Bold = True Then
                                   Range("AT" & i).Value = "Yes"
                                   Range("AT" & i).Font.Bold = True
                                   Error_Count_Clm = Error_Count_Clm - 1
                                   Range("AY" & i).Value = Error_Count_Clm
                                
                                    Else
                                        Range("AT" & i).Value = "No"
                                        Range("AY" & i).Value = Error_Count_Clm
                                
                                End If
                                
                            
                            'Prt Actt
                                If Range("AB" & i).Font.Bold = True Then
                                    Range("AU" & i).Value = "Yes"
                                    Range("AU" & i).Font.Bold = True
                                    Error_Count_Clm = Error_Count_Clm - 1
                                    Range("AZ" & i).Value = Error_Count_Clm
                                
                                    Else
                                        Range("AU" & i).Value = "No"
                                        Range("AZ" & i).Value = Error_Count_Clm
                                
                                End If
                            
                            
                            'Other Errors
                                If Error_Count_Clm > 0 Then
                                    Range("AV" & i).Value = "Yes"
                                    Range("AV" & i).Font.Bold = True
                                    Error_Count_Clm = Error_Count_Clm - 1
                                    Range("BA" & i).Value = Error_Count_Clm
                                    
                                    Else
                                        Range("AV" & i).Value = "No"
                                        Range("BA" & i).Value = Error_Count_Clm
                                
                                End If
                            
                                
                        Range("A" & i & ":BA" & i).Copy Sheets("Error.Items").Range("C" & Error_Row)
                        Sheets("Error.Items").Range("A" & Error_Row).Value = ActiveSheet.Name
                        Sheets("Error.Items").Range("B" & Error_Row).Value = i
                        Error_Row = Error_Row + 1
                
                    End If


            Next i


        Next
    
    End If
    
Next




'Sort the data
    'Find the last row first
        Sheets("Error.Items").Activate
        LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
            LookIn:=xlFormulas, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False).Row
    
    'Sorting the Tab Names in Order
        With Sheets("Error.Items").Sort
            .SortFields.Add Key:=Range("A3"), Order:=xlAscending
            .SortFields.Add Key:=Range("B3"), Order:=xlAscending
            .SetRange Range("A3:AV" & LastRow)
            .Header = xlNo
            .Apply
        End With




'Formatting the "Error.Items" tab to autofit
    Sheets("Error.Items").Columns("A:AX").EntireColumn.AutoFit




'Turn on alerts, screen updates, and calculate
        'Turn On Display Alerts
            Application.DisplayAlerts = True


        'Turn on Screen Update
            Application.ScreenUpdating = True


        'Turn off Automatic Calculations
            Calculate


'Freeze Panes on the "Error.Items" Tab and places the cursor in cell C3
        Sheets("Error.Items").Activate
        Sheets("Error.Items").Range("C3").Select
        ActiveWindow.FreezePanes = False
        ActiveWindow.FreezePanes = True


End Sub
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
So why are you repeating 8,9,10,11 and 12 ??

Code: 
If J = 1 Or J = 2 Or J = 6 Or J = 7 _
Or J = 8 Or J = 9 Or J = 10 Or J = 11 Or J = 12 _
Or J = 9 Or J = 10 Or J = 11 Or J = 12 Or J = 14 _
 
Upvote 0
Is it possible that there is more than one error on a given row....so it copies the row for each error ??
 
Upvote 0
Michael M

There is more than one error per row, but it runs through each row with the following code and then copies that row over. Maybe it's running through each worksheet twice?

Code: 
                For J = 1 To 41


                    If J = 1 Or J = 2 Or J = 6 Or J = 7 _
                        Or J = 8 Or J = 9 Or J = 10 Or J = 11 Or J = 12 _
                        Or J = 14 Or J = 15 Or J = 17 Or J = 19 Or _
                        J = 20 Or J = 21 Or J = 22 Or J = 23 Or J = 24 _
                        Or J = 27 Or J = 30 Or J = 31 Or J = 32 Or _
                        J = 33 Or J = 34 Or J = 35 Or J = 36 Or _
                        J = 37 Or J = 38 Or J = 39 Or J = 40 Then
                            'do nothing


                        ElseIf Cells(i, J) = "" And J = 3 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "No CC Xref" And J = 5 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf J = 5 Then
                            If Cells(i, J) = "" Or Cells(i, J) = "No CC Xref" Then
                                Cells(i, J).Font.Bold = True
                                Cells(i, J).Interior.ColorIndex = 3
                            End If
            
                        ElseIf J = 13 Then
                            If Cells(i, J) <> 1 And Cells(i, J) <> 3 Then
                                Cells(i, J).Font.Bold = True
                                Cells(i, J).Interior.ColorIndex = 3
                            End If
            
                        ElseIf Cells(i, J) = "" And J = 16 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                
                        ElseIf Cells(i, J) = "" And J = 18 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 26 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                    
                        ElseIf Cells(i, J) = "!Xref Error" And J = 28 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 29 And Cells(i, 25) <> "REVENUE" Then
                            Cells(i, 25).Font.Bold = True
                            Cells(i, 25).Interior.ColorIndex = 2
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
            
                        ElseIf Cells(i, J) = "" And J = 41 Then
                            Cells(i, J).Font.Bold = True
                            Cells(i, J).Interior.ColorIndex = 3
                    
                    End If
            
                    'Count the number of errors in each row
                        If Cells(i, J).Font.Bold = True Then
                            Error_Count = Error_Count + 1
                        End If
                 
                Next J
 
Upvote 0
Any chance of uploading the sheet to dropbox ??
 
Upvote 0
Is that allowed?

If so, I would not mind modifying to remove some data and then loading it.

Right now, there are 110 tabs so I could just leave two tabs and modify the data.
 
Upvote 0
I could not find a link to where I could just post it.

May I just private message it to you?
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
how to automatically clear text if text in another cell is removed
Replies
1
Views
111
Joe4
Joe4
A
  • Solved
doesn't show data in listbox on form without any error in this code
Replies
6
Views
116
Abdo
A
A
  • Question Question
VBA for setting up the printing pages per sheet
Replies
0
Views
493
Aurum1
A
R
  • Question Question
VBA - AUTO FIT, Can we remove make the sum formula in below code
Replies
1
Views
157
Joe4
Joe4
T
  • Question Question
VBA Macro suddenly extremely slow. Need help in how to edit it.
Replies
3
Views
263
bobsan42
bobsan42

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