VBA Code to Find Errors in a Sheet and Paste it

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 I will give feedback.

The following is code to search for any errors and flag the cell by filling it red and bolding it. How would I then copy the entire row and past it into a sheet titled "Error.Log" when there is or more or errors in that row.

Code: 
Sub ErrorCheck()


'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
        
'Find the last row of data
   Sheets("Data").Activate
            
    LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row
            
    Error_Row = 3


    For i = 3 To LastRow


        For j = 1 To 41


            If j = 7 Or j = 20 Or j = 21 Or j = 22 Or j = 23 Or j = 31 _
            Or j = 32 Or j = 34 Or j = 35 Or j = 36 Or j = 37 _
            Or j = 39 Or j = 40 Then
            'do nothing


            ElseIf Cells(i, j) = "No AFE Xref" And j = 9 Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3
                    
            ElseIf j = 8 Or j = 9 Or j = 10 Or j = 11 Then
            'do nothing
            
            ElseIf Cells(i, j) = "!Xref Error" Or Cells(i, j) = "" Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3


            End If
        
        Next j


    Next i






'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


'Place the curser in cell


End Sub
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Try ....UNTESTED
Also. make sure Sheet "Error.Log" is the correct syntax
Code: 
Option Explicit
Sub ErrorCheck()
'Turn off alerts, screen updates, and automatic calculation
        'Turn off Display Alerts
  With Application
  .DisplayAlerts = False
        'Turn off Screen Update
  .ScreenUpdating = False
        'Turn off Automatic Calculations
  .Calculation = xlManual
End With
'Dimensioning
    Dim LastRow As Long, Error_Row As Long, lr2 As Long, i As Long, j As Long
    Dim Ib As Integer, Lc As Integer

'Find the last row of data
   Sheets("Data").Activate
    Lc = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    LastRow = Cells.Find("*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row
    lr2 = Sheets("Error.log").Cells(Rows.Count, "A").End(xlUp).Row
    Error_Row = 3
    For i = 3 To LastRow
        For j = 1 To 41
            If j = 7 Or j = 20 Or j = 21 Or j = 22 Or j = 23 Or j = 31 _
            Or j = 32 Or j = 34 Or j = 35 Or j = 36 Or j = 37 _
            Or j = 39 Or j = 40 Then
            'do nothing
            ElseIf Cells(i, j) = "No AFE Xref" And j = 9 Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3
            ElseIf j = 8 Or j = 9 Or j = 10 Or j = 11 Then
            'do nothing
            ElseIf Cells(i, j) = "!Xref Error" Or Cells(i, j) = "" Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3
            End If
             If Cells(i, j).Font.Bold = True Then
                Ib = Ib + 1
             End If
        Next j
        If Ib > 0 Then
         Rows(i).Copy Sheets("Error.log").Range("A" & lr2)
         lr2 = lr2 + 1
         End If
    Next i
'Turn on alerts, screen updates, and calculate
        'Turn On Display Alerts
    With Application
    .DisplayAlerts = True
       'Turn on Screen Update
    .ScreenUpdating = True
        'Turn off Automatic Calculations
    .Calculation = xlAutomatic
End With
'Place the curser in cell
End Sub
 
Upvote 0
OilEconomist said:
Thanks in advance for any suggestions for which I will give feedback.

The following is code to search for any errors and flag the cell by filling it red and bolding it. How would I then copy the entire row and past it into a sheet titled "Error.Log" when there is or more or errors in that row.

Code: 
Sub ErrorCheck()


'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
        
'Find the last row of data
   Sheets("Data").Activate
            
    LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row
            
    Error_Row = 3


    For i = 3 To LastRow


        For j = 1 To 41


            If j = 7 Or j = 20 Or j = 21 Or j = 22 Or j = 23 Or j = 31 _
            Or j = 32 Or j = 34 Or j = 35 Or j = 36 Or j = 37 _
            Or j = 39 Or j = 40 Then
            'do nothing


            [COLOR=#ff0000]ElseIf[/COLOR] Cells(i, j) = "No AFE Xref" [COLOR=#ff0000]And j = 9 [/COLOR]Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3
                    
            [COLOR=#ff0000]ElseIf[/COLOR] j = 8 Or [COLOR=#ff0000]j = 9[/COLOR] Or j = 10 Or j = 11 Then
           [COLOR=#ff0000] 'do nothing[/COLOR]
            
            ElseIf Cells(i, j) = "!Xref Error" Or Cells(i, j) = "" Then
                    Cells(i, j).Font.Bold = True
                    Cells(i, j).Interior.ColorIndex = 3


            End If
        
        Next j


    Next i






'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


'Place the curser in cell


End Sub
Click to expand...

I was not quite sure what your exact requirement was as I found some of your code confusing. Such as the two consecutive If statements would seem to be in red would seem to conflict (although the second is commented out). That said, see if this gets you close to where you want to be. The copied line will start in cell A1 on the "Error.Log" sheet and continue down.

Code: 
Sub ErrorCheck()


'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 arr, pos
    Dim LastRow As Long, lRow As Long
    Dim Error_Row As Long
    Dim i As Long, j As Integer
    Dim err As Boolean
        
    arr = Array(7, 20, 21, 22, 23, 31, 32, 34, 35, 36, 37, 39, 40)
'Find the last row of data
   Sheets("Data").Activate
            
    LastRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, MatchCase:=False).Row
            
    Error_Row = 3


    For i = 3 To LastRow
        err = False
        For j = 1 To 41
            pos = Application.Match(j, arr, 0)
            If Not IsError(pos) Then GoTo InArr
            If Cells(i, j) = "No AFE Xref" And j = 9 Then
                Cells(i, j).Font.Bold = True
                Cells(i, j).Interior.ColorIndex = 3
                err = True
            End If
            If Cells(i, j) = "!Xref Error" Or Cells(i, j) = "" Then
                Cells(i, j).Font.Bold = True
                Cells(i, j).Interior.ColorIndex = 3
                err = True
            End If
InArr:
        Next j
        If err Then
            With Worksheets("Error.Log")
                lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                Worksheets("Data").Rows(i).Copy .Range("A" & lRow)
            End With
        End If
    Next i


'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




'Place the curser in cell




End Sub
 
Upvote 0
Thx for the feedback...glad it worked..:beerchug:
 
Upvote 0
Thanks for the response.

I could have left the j = 9 on the first ElseIf after the If.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA for setting up the printing pages per sheet
Replies
0
Views
604
Aurum1
A
O
  • Question Question
Change MS Word Doc Properties via MS Excel VBA Macro
Replies
3
Views
695
NdNoviceHlp
NdNoviceHlp
O
  • Solved
MS Excel VBA Macro to Open a MS Word File, Save the File and then Close the File
Replies
3
Views
695
OilEconomist
O
M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
122
Mazurofgod
M
S
  • Question Question
Using VBA to Flag and Calculate Overlapping Shift Times
Replies
0
Views
485
Snort
S

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

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