' This will only work for US formatted dates, default AP TB
' Export the APTB as a tab delimited file
' Import the data into a Macro Enabled Excel Sheet
' Copy and paste this code into a VB Module, and run it against your sheet
' It will reformat the data to a more useful state
'
Dim a, b, TheVend, LineCheck3, LineCheck1, LineCheck7, LC2, LC3, LC5, LC6, LC8, LC15
a = 0
' this controls how many columns to the right it looks for the outstanding amounts
b = 6
'Insert index
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
'Insert vendor column
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
Do Until ActiveCell.Offset(a, 2).Value = "Vendor Totals:"
ActiveCell.Offset(a, 1).Value = a
LC2 = ActiveCell.Offset(a, 2).Value
LC3 = ActiveCell.Offset(a, 3).Value
LineCheck3 = ActiveCell.Offset(a, 4).Value
LineCheck1 = ActiveCell.Offset(a, 2).Value
LineCheck7 = ActiveCell.Offset(a, 7).Value
LC5 = ActiveCell.Offset(a, 5).Value
LC6 = ActiveCell.Offset(a, 6).Value
LC8 = ActiveCell.Offset(a, 8).Value
If ActiveCell.Offset(a, 2).Value = "Vendor ID:" Then
TheVend = ActiveCell.Offset(a, 3).Value
End If
If (Len(Trim(LineCheck3)) <= 3) And (LineCheck3 <> "") And (LC2 <> "") And (LC5 <> "") And (LineCheck1 <> "Aged Totals:") Then
ActiveCell.Offset(a, 0).Value = TheVend
' scan all columns from the right for the first value it can find for outstanding doc amt
If LineCheck7 <> "" Then
ActiveCell.Offset(a, 8).Value = LineCheck7
Else
Do While LC8 = "" And b < 15
LC15 = ActiveCell.Offset(a, b).Value
ActiveCell.Offset(a, 8).Value = LC15
LC8 = ActiveCell.Offset(a, 8).Value
ActiveCell.Offset(a, b).Value = ""
b = b + 1
Loop
b = 6
End If
End If
a = a + 1
Loop
' Sort all records with a vendor
Range("A1:Q50000").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:Q50000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Put in proper headers
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "VendorID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Index"
Range("C1").Select
ActiveCell.FormulaR1C1 = "VchrNmbr"
Range("D1").Select
ActiveCell.FormulaR1C1 = "DocNo"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Type"
Range("F1").Select
ActiveCell.FormulaR1C1 = "DocDate"
Range("G1").Select
ActiveCell.FormulaR1C1 = "DueDate"
Range("H1").Select
ActiveCell.FormulaR1C1 = "OrigDocAmt"
Range("I1").Select
ActiveCell.FormulaR1C1 = "OSDocAmt"
Range("A1").Select
' Copy good records to new sheet
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
' Remove unwanted characters like $
Cells.Replace What:="$", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'Format amount column as currency
Columns("H:I").Select
Selection.Style = "Currency"
End Sub
No comments:
Post a Comment