VBA cleanup request

P

philwojo

Well-known Member
Joined
May 10, 2013
Messages
533
OK, so all of this code is working for me, but I am wondering, and wanting to learn, if there are better or more efficient ways of doing the things I have in the below.

I am not experiencing slow processing or anything like that now, just trying to learn as I go here. I know there is a lot of unique data points in here and you don't have full context of what is going on, so I realize any feedback may be limited because of that. I have a lot of notes in here too that are for me in the future, so obviously ignore those.

Thanks for any feedback or assistance you may offer.

Code: 
Sub RecordValueCheck()

'UPI = Unique Payable Identifer - from 2100 record field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL] 
'TPA = Total Payable Amount - from 2100 record field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=5]#5[/URL] 
'ITA = Invoice Total Amount - from 3000 recrod field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=8]#8[/URL] 
'CSPR = Count Submitted Payable Request - from 5000 record field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL] 
'T2100Count = A Counter for the number of time 2100 records show up
'RLN = Remittance Line number - from 3000 records field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=4]#4[/URL] 
'Rng = Range of the Cells to be checked


Dim Cell As Range, Cell2 As Range, Cell3 As Range, UPI As Range, i As Integer
Dim ErrorCount As Integer, TPA As Integer, ITA As Integer, ITACell As Range, TPACell As Range
Dim CSPR As Integer, CSPRCell As Range, T2100Count As Integer
Dim RLN As Integer, RLNCell As Range, RLNCount As Integer
Dim Rng As Range, Dn As Range, nRng As Range
Dim nR As Range, Rng1 As Range, c As Long, R As Range


Const num = 2100


Set Rng = Range(Range("B23"), Range("B" & Rows.Count).End(xlUp))


Application.EnableEvents = False
Application.ScreenUpdating = False


Worksheets("PIF Checker Output - Horz").Activate


ErrorCount = 0




' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=4]#4[/URL]  for 3000 records Check
'Check to make sure that for any 3000 records they have a unique Remittance Line Number
'The count should always start with 1 and be sequential


For Each Dn In Rng
   If Dn.Value = num Then
      If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
    End If
 Next Dn
For Each Dn In nRng
    c = 1
    Do While Dn.Offset(c) = 3000
        If Rng1 Is Nothing Then Set Rng1 = Dn.Offset(c) Else Set Rng1 = Union(Rng1, Dn.Offset(c))
        c = c + 1
    Loop
 Next Dn
    For Each nR In Rng1.Areas
      c = 0
      For Each R In nR
            c = c + 1
            If Not R.Offset(, 3).Value = c Then
                ErrorCount = ErrorCount + 1
                R.Offset(, 3).Interior.Color = vbRed
                R.Offset(, 3).Font.Color = vbYellow
                R.Offset(, 3).Font.Bold = True
          End If
      Next R
Next nR


'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=4]#4[/URL]  for 3000 records Check


' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  Check
'Check to make sure all values in Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  are valid
With ThisWorkbook.Worksheets("PIF Checker Output - Horz")
    For Each Cell In Rng
        If Cell.Value <> 1000 And Cell.Value <> 2100 And Cell.Value <> 3000 And Cell.Value <> 5000 Or Len(Cell.Value) <> Cells(5, 2).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Interior.Color = vbRed
            Cell.Font.Bold = True
            Cell.Font.Color = vbYellow
        End If


    Next
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  Check


' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  for 5000 Record Count Check
'Check to see if the Count of Submitted Payable Requests (2100 records) matches this field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL]  in the 5000 recrod
'Using T2100Count and CSPR as variables
'Also checks the Payable End Date for the 2100 Records to make sure they are set for after today's date.


T2100Count = 0


    For Each Cell In Rng
        
        If Cell.Value = 2100 Then
            T2100Count = T2100Count + 1
            If Cell.Offset(0, 5).Value <> "USD" Then
                ErrorCount = ErrorCount + 1
                Cell.Offset(0, 5).Interior.Color = vbRed
                Cell.Offset(0, 5).Font.Bold = True
                Cell.Offset(0, 5).Font.Color = vbYellow
            ElseIf DateSerial(Right((Cell.Offset(0, 7).Value), 4), Left((Cell.Offset(0, 7).Value), 2), Mid((Cell.Offset(0, 7).Value), 3, 2)) < Date Then
                ErrorCount = ErrorCount + 1
                Cell.Offset(0, 7).Interior.Color = vbRed
                Cell.Offset(0, 7).Font.Bold = True
                Cell.Offset(0, 7).Font.Color = vbYellow
            End If
        ElseIf Cell.Value = 5000 Then
            CSPR = Cell.Offset(0, 1).Value
            Set CSPRCell = Cell.Offset(0, 1)
        End If
    Next
        If T2100Count <> CSPR Then
            ErrorCount = ErrorCount + 1
            CSPRCell.Interior.Color = vbRed
            CSPRCell.Font.Bold = True
            CSPRCell.Font.Color = vbYellow
        End If
    
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL]  5000 Record Check


' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL]  Check
'Check to make sure that all values in Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL]  are set to "1.0" as that is required.
    For Each Cell In Rng
        If Cell.Value = 1000 Or Cell.Value = 2100 Or Cell.Value = 3000 Then
                Set Cell2 = Cell.Offset(0, 1)
                    If Cell2.Value <> "1.0" Or Len(Cell2.Value) <> Cells(5, 3).Value Then
                        ErrorCount = ErrorCount + 1
                        Cell2.Interior.Color = vbRed
                        Cell2.Font.Bold = True
                        Cell2.Font.Color = vbYellow
                    End If


                ElseIf Cell.Value = 5000 Or Cell.Value = "5000" Then
                        Application.EnableEvents = True
                        Application.ScreenUpdating = True
                        'Exit Sub
                End If
    Next
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL]  Check


' ****************************************************************


' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=5]#5[/URL] ,8 Check
'Check to see that the total of the Invoice amounts is equal to the Total Payable Amount
'Using TPA and ITA as variables


    
    For Each Cell In Rng
'Get the TPA amount from field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=5]#5[/URL] , column-F
        If Cell.Value = 2100 Then
            TPA = Cell.Offset(0, 4).Value
            ITA = 0
            Set Cell2 = Cell.Offset(1, 0)
            i = 1
            Do While Cell2.Value = 3000
                ITA = Cell2.Offset(0, 7).Value + ITA
                i = i + 1
                Set Cell2 = Cell.Offset(i, 0)
            Loop
        If ITA = TPA Then
            Else
                ErrorCount = ErrorCount + 1
                Cell.Offset(0, 4).Interior.Color = vbRed
                Cell.Offset(0, 4).Font.Bold = True
                Cell.Offset(0, 4).Font.Color = vbYellow
        End If
        
        ElseIf Cell.Value = 5000 Then
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    Next
    
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=5]#5[/URL] ,8 Check


' ****************************************************************


'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 6 for 2100 records Check
'Check to make sure the value is either a Yes or No


    For Each Cell In Rng
               
        If Cell.Value = 2100 Then
            If Cell.Offset(0, 15).Value <> "YES" And Cell.Offset(0, 15).Value <> "Yes" And Cell.Offset(0, 15).Value <> "NO" And Cell.Offset(0, 15).Value <> "No" Then
                ErrorCount = ErrorCount + 1
                Cell.Offset(0, 15).Interior.Color = vbRed
                Cell.Offset(0, 15).Font.Bold = True
                Cell.Offset(0, 15).Font.Color = vbYellow
            End If
        End If
    Next
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 6 for 2100 records Check


' ****************************************************************
'Start Field #'s 18-20 and 32-34 Check
'Check to make sure Fields 18-20 and 32-34 are always blank, they are reserved for future use.


    For Each Cell In Rng
        If Len(Cell.Offset(0, 17).Value) <> Cells(10, 19).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 17).Interior.Color = vbRed
            Cell.Offset(0, 17).Font.Bold = True
            Cell.Offset(0, 17).Font.Color = vbYellow
        End If
        If Len(Cell.Offset(0, 18).Value) <> Cells(10, 19).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 18).Interior.Color = vbRed
            Cell.Offset(0, 18).Font.Bold = True
            Cell.Offset(0, 18).Font.Color = vbYellow
        End If
        If Len(Cell.Offset(0, 19).Value) <> Cells(10, 19).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 19).Interior.Color = vbRed
            Cell.Offset(0, 19).Font.Bold = True
            Cell.Offset(0, 19).Font.Color = vbYellow
        End If
        If Len(Cell.Offset(0, 31).Value) <> Cells(10, 33).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 31).Interior.Color = vbRed
            Cell.Offset(0, 31).Font.Bold = True
            Cell.Offset(0, 31).Font.Color = vbYellow
        End If
        If Len(Cell.Offset(0, 32).Value) <> Cells(10, 33).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 32).Interior.Color = vbRed
            Cell.Offset(0, 32).Font.Bold = True
            Cell.Offset(0, 32).Font.Color = vbYellow
        End If
        If Len(Cell.Offset(0, 33).Value) <> Cells(10, 33).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 33).Interior.Color = vbRed
            Cell.Offset(0, 33).Font.Bold = True
            Cell.Offset(0, 33).Font.Color = vbYellow
        End If
    Next
'End Field #'s 18-20 and 32-34 Check


' ****************************************************************


'Start Field #'s 3 Check for Record 1000
'Check to make sure the length of Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL]  for a 1000 record is 7 characters sa this is the ORD ID


    For Each Cell In Rng
    If Cell.Value = 1000 Then
        If Len(Cell.Offset(0, 2).Value) <> Cells(5, 4).Value Then
            ErrorCount = ErrorCount + 1
            Cell.Offset(0, 2).Interior.Color = vbRed
            Cell.Offset(0, 2).Font.Bold = True
            Cell.Offset(0, 2).Font.Color = vbYellow
        End If
    End If
    Next
'End Field #'s 3 Check for Record 1000


' ****************************************************************






'Start Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL]  Check
'Check to make sure that the Values for 3000 records in field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL]  match their 2100 record field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL]  counterpart.


'Check Length of 2100 and 3000 cells are not greather than max field length
    For Each Cell In Rng
        If Cell.Value = 2100 Or Cell.Value = 3000 Then
            Set Cell = Cell.Offset(0, 2)
            If Len(Cell.Value) > Cells(10, 4).Value Then
                ErrorCount = ErrorCount + 1
                Cell.Interior.Color = vbRed
                Cell.Font.Bold = True
                Cell.Font.Color = vbYellow
            End If
        End If
    Next
    
    For Each Cell In Rng
    Set UPI = Cell.Offset(0, 2)
        If Cell.Value = 2100 Then
            Set Cell2 = Cell.Offset(1, 0)
            i = 1
            Do While Cell2.Value = 3000
                Set Cell3 = Cell2.Offset(0, 2)
                If Cell3.Value = UPI.Value Then
                    ElseIf Cell3.Value <> UPI.Value Then
                        ErrorCount = ErrorCount + 1
                        Cell3.Interior.Color = vbRed
                        Cell3.Font.Bold = True
                        Cell3.Font.Color = vbYellow
                End If
                i = i + 1
                Set Cell2 = Cell.Offset(i, 0)
            Loop


'The section below must be at the end of my file so it totals up all the ErrorCount values and doesn't exit
'the sub without displaying the Message Box.
'Don't put any code below this


        ElseIf Cell.Value = 5000 Then
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            'Displays a message box that the moving of the raw data has finished.
            MsgBox "Total Number of Potential Errors Found = " & ErrorCount, vbInformation
            Range("A23").Value = "Total # of Errors = " & ErrorCount
            Exit Sub
        End If
    Next
    
'End Field [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=3]#3[/URL]  Check


' ****************************************************************


Application.EnableEvents = True
Application.ScreenUpdating = True


End With




Application.EnableEvents = True
Application.ScreenUpdating = True


End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Hi philwojo,

Here are a few comments and suggestions.

1. Use fully qualified references to ranges that include the workbook and worksheet. Otherwise the code is dependent on which workbook and worksheet are active. That's prone to mistakes and makes the code harder to follow.

Code: 
Set Rng = Range(Range("B23"), Range("B" & Rows.Count).End(xlUp))

Replace with... (if that's the correct sheet, it can't be determined from the code what worksheet is active at this point)
Code: 
With ThisWorkbook.Sheets("PIF Checker Output - Horz")
   Set Rng = Range(.Range("B23"), .Range("B" & .Rows.Count).End(xlUp))
End With

2. The code relies heavily on the existing relative positions of data on the sheet. This can make it difficult to maintain the workbook if you want to add, delete or move fields. Unless you know that it's unlikely the layout will be modified, consider using methods that allow you to reduce or eliminate the need to modify the VBA code for minor changes in the layout.

Those methods include:
a. Use of Name Ranges that can be referenced by VBA.
b. Have your VBA code find ranges using header and/or row labels that won't change.
c. Use constants in VBA code to map column numbers of fields. (this still requires editing of code if field locations change, but at least it can be done in one place).


3. This isn't a VBA comment, but have you considered using Conditional Formatting as a simpler approach than VBA for many of the steps this code is doing?
 
Last edited:
Upvote 0
Thanks for the feedback Jerry, I appreciate all of it. I will update my code based on your suggestion in #1 .

For #2 , the positions shouldn't change once the final decisions are in place, but I am following your logic on that topic. I have not really used named ranges yet, but I do understand that concept. I am also not sure I can use headers in this case as I have 4 sets of headers for each column, the data set uses multiple data types but they are all in one file. I probably do need to add more constants where possible, rather than using the Offset values, I might look in to that as well.

For #3 , I have used CF in the past for a similar version of this data set, but it, for me, is harder to maintain with all of these rules. For me it is easier to scroll through the code and update things where necessary rather than having to select the correct range of cells and see what CF stuff I have in there. Plus I don't know of an easy way to keep track of the total number of errors that are coming up using CF, at least I can track that with my code and pop out a total at the end.

Again, I appreciate your suggestions, I am always trying to learn and improve.

Phil
 
Upvote 0
You must log in or register to reply here.

Similar threads

Agnarr
  • Solved
Checkbox Timestamp with VBA
Replies
3
Views
314
bobsan42
bobsan42
S
  • Solved
Combine two codes in one worksheet change events
Replies
3
Views
303
Alex Blakenburg
A
S
  • Solved
VBA: Am I double-calling a Sub given nested If statements? Or other inefficiencies?
Replies
8
Views
283
dreid1011
dreid1011
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
448
Agnarr
Agnarr
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
471
Legacy 352679
L

Forum statistics

Threads
1,216,113
Messages
6,128,905
Members
449,477
Latest member
panjongshing

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