AR Aging Cleanup via VBA

[ptmuldoon]

I am working to 'clean up' an AR aging that is being Exported from Microsoft Dynamics (formerly Great Plains) and can't seem to get this to work correctly.

The VBA is looking through the file to strip it down to a raw detail for easier summarization and pivot table use. And this will be done frequently on daily or monthly basis as needed.

I've attached a sample and the below code as well. If you run the macro, you'll see what I'm getting at. And this appears close I think, yet always gives the wrong totals. I think part of that is the document exporting the payment info into Column D but not all the time.

I just can't figure If I'm missing something in the macro, maybe a bad file?

Sub Testing()
    Dim LastRow, LastCol, HeaderRow As Long
    Dim rng, rCell As Range
    Dim ColNum As String
    
    Sheets("Original").Copy After:=Sheets(Sheets.Count)
    
    'ActiveSheet.Name = "NewWS"
    
    LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    
    'Copy the Customer Number and Name Down for blank values
    Set rng = Range("A2:A" & LastRow).SpecialCells(4)
    For Each rCell In rng
        rCell.Value = rCell.Offset(-1).Value
    Next rCell
    
    'Start Clean Up. Work off of the 'Amount' Column
    Cells.Find(What:="Amount", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
    ColNum = ColumnLetter(ActiveCell.Column)
    
    'Remove Stuff Above Header
    HeaderRow = ActiveCell.Row - 1
    Rows("1:" & HeaderRow).EntireRow.Delete
    
    Set rng = Range(ColNum & "2:" & ColNum & LastRow)
    'Shift Payment Date and Info Over if necessary
    For Each rCell In rng
        If IsDate(rCell.Offset(0, -2)) Then
            rCell.Value = rCell.Offset(0, -1).Value
            rCell.Offset(0, 1).Value = rCell.Offset(0, -1).Value
            rCell.Offset(0, -1) = Format(rCell.Offset(0, -2), "Short Date")
            rCell.Offset(0, -2) = JUSTLETTERS(rCell.Offset(0, -3))
        End If
    Next rCell

    'Next Remove all Customer Totals
    For Each rCell In rng
        If Not IsDate(rCell.Offset(0, -1)) Then
            rCell.EntireRow.Delete
        End If
    Next rCell
    
    Set rng = Range("A2:" & ColNum & LastRow)
    For Each rCell In rng
        If rCell = "." Or rCell = "Balance" Then
            rCell.EntireRow.Delete
        End If
    Next rCell
      
    'Recompute Last Row and Column
    LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    
    'Format Numbers
    Cells.Find(What:="Amount", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
    Set rng = Range(ActiveCell.Offset(1, 0).Address & ":" & ColumnLetter(ActiveCell.End(xlToRight).Column) & LastRow)
    For Each rCell In rng
        rCell.Value = rCell.Value / 1000
        rCell.Value = rCell.Value * 1000
        rCell.Value = Format(rCell.Value, "Currency")
    Next rCell

    
End Sub



Function JUSTLETTERS(pWorkRng As Range) As String
    Dim xValue As String
    Dim OutValue As String
    Dim XIndex As Long

    xValue = pWorkRng.Value
    For XIndex = 1 To VBA.Len(xValue)
        If Not VBA.IsNumeric(VBA.Mid(xValue, XIndex, 1)) Then
            OutValue = OutValue & VBA.Mid(xValue, XIndex, 1)
        End If
    Next
    JUSTLETTERS = OutValue
End Function

Function ColumnLetter(ColumnNumber As Long) As String
    Dim n As Long
    Dim c As Byte
    Dim S As String

    n = ColumnNumber
    Do
        c = ((n - 1) Mod 26)
        S = Chr(c + 65) & S
        n = (n - c) \ 26
    Loop While n > 0
    ColumnLetter = S
End Function

Edit.
Forgot to mention, for some strange reason, you also get prompted about existing names existing, but there are no named ranges in the file?