G
Guest
I built a report in Excel that goes out to a number of files based on Branch,
Customer Name , Status of days. This is for our Accounts Receivables agings ,
that ranges from “Current†through “360†days of money owed to us. This
report is made up of a number of macros that creates a pivot table called
Test Receivables. Once the table is created it fills in the Customer number
and Customer name. The problem is if the Customer has more than one Customer
number it won’t place the name in the next cell . I will list my script ,
but I know I might need to explain further, I just figured I would start
here. The names of the Macros I need help with are (Sub Populate_Customer) &
(Sub Schedule Count). They are about 3 quarters of the way down the page.
Thanks Todd
Sub Receivables_One_Week()
'
' Receivables_One_Week Macro
'
Application.StatusBar = "Importing ......North Central..."
Application.ScreenUpdating = False
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\North Central(08).xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"Test Receivables.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Application.StatusBar = "Importing ......Taylor.........."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\Taylor(06).xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("Taylor(06).xls").Close
Application.StatusBar = "Importing ......South Central......."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\South Central(07).xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("South Central(07).xls").Close
Application.StatusBar = "Importing ......Convenience Works.........."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\Convenience
Works-Foodservice.xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Windows("Convenience Works-Foodservice.xls").Close
Application.DisplayAlerts = True
Application.StatusBar = "Creating Report.........."
Windows("Test Receivables.xls").Activate
Range("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("M:N").Select
Selection.Cut Destination:=Columns("P:Q")
Columns("K:K").Select
Selection.Style = "Comma"
Windows("Central DATA.xls").Activate
Sheets("Program").Select
Rows("30:30").Select
Selection.Copy
Windows("Test Receivables.xls").Activate
Rows("1:1").Select
ActiveSheet.Paste
Columns("A
").EntireColumn.AutoFit
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 13).FormulaR1C1 =
"='[Central DATA.xls]Program'!R4C4"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).FormulaR1C1 =
"=RC[1]-RC[-8]"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).Select
Selection.Style = "Comma"
Columns("O:O").NumberFormat = "@"
Columns("O:O").Select
With Selection
.HorizontalAlignment = xlCenter
End With
' Pivot Table
Application.StatusBar = "Creating Pivot Table..."
Range("A1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable1"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable1").SmallGrid = False
ActiveSheet.PivotTables("PivotTable1").AddFields
RowFields:=Array("SubBranch", _
"Customer Name", "Customer "), ColumnFields:="Status of days"
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With
Application.CommandBars("PivotTable").Visible = False
Columns("A:C").EntireColumn.AutoFit
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("B5").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
Range("B5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter Field:=2
Selection.AutoFilter
Columns("D:L").Select
Selection.Style = "Comma"
Columns("A:L").EntireColumn.AutoFit
Columns("D:K").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
End Sub
Sub SummaryBadDebt()
'
' Macro2 Macro
'
'
Dim Rng As Range
Dim Pth As String
Pth = ThisWorkbook.Path
ChDir Pth
Application.ScreenUpdating = False
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
Range("A11").Select
Range(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable2"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").SmallGrid = False
ActiveSheet.PivotTables("PivotTable2").AddFields
RowFields:=Array("SubBranch", _
"Customer Name", "Customer "), ColumnFields:="Status of days"
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With
Sub Pasties()
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A5").Select
' Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
' Range("B5").Select
' Range(Selection, Selection.End(xlDown)).Select
' Selection.EntireRow.Delete
' Selection.AutoFilter Field:=2
' Selection.AutoFilter
' Sorts Status of days
Call FormatDays
' Copies Customer names down to blank cells
Call PopulateCustomerName
' Delets zero Bad Debt rows
Call KillZero
' Subtotal Customer Names for group totals
' Call Subtotalme
' fill copies down of names line
Call RTotal
If ActiveCell <> "" Then GoTo LastOne
Selection.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
LastOne:
End Sub
____________________________________________________________________
Sub PopulateCustomerName()
'
' Application.ScreenUpdating = False
' Windows("Test Receivables.xls").Activate
' Sheets("Schedule VI").Select
Range("B5").Select
Again:
If ActiveCell.Offset(2, -1) = "Grand Total" Then Exit Sub
Call NameCount
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then GoTo Again
End Sub
Sub NameCount()
'
Do While ActiveCell.Offset(1, 0).Value = Empty
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Loop
End Sub
____________________________________________________________________
Sub FormatDays()
Columns("D:L").Select
Selection.Style = "Comma"
Columns("A:L").EntireColumn.AutoFit
Columns("D:K").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""MS Sans Serif,Bold""&12&A" & "&8&F"
.RightHeader = ""
.LeftFooter = "&12&F"
.CenterFooter = "&8&P of &N"
.RightFooter = "&8&D &T"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
Range("E3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Call FillDays
Columns("D
").EntireColumn.AutoFit
Windows("Central Scorecard.xls").Activate
Sheets("Sheet3").Select
Range("L4:L5").Select
Selection.Copy
Windows("Top 20 Summary.xls").Activate
Range("L4").Select
ActiveSheet.Paste
Range("L5").Copy
Range("K6").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("D:O").EntireColumn.AutoFit
End Sub
Sub FillDays()
If Range("E4") = "001 - 030" Then GoTo TstF4
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Range("E4").Select
ActiveCell.FormulaR1C1 = "'000 - 030"
TstF4:
If Range("F4") = "031 - 060" Then GoTo TstG4
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("F4").Select
ActiveCell.FormulaR1C1 = "'031 - 060"
TstG4:
If Range("G4") = "061 - 090" Then GoTo TstH4
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G4").Select
ActiveCell.FormulaR1C1 = "'061 - 090"
TstH4:
If Range("H4") = "091 - 180" Then GoTo TstI4
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H4").Select
ActiveCell.FormulaR1C1 = "'091 - 180"
TstI4:
If Range("I4") = "181 - 360" Then GoTo TstJ4
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Range("I4").Select
ActiveCell.FormulaR1C1 = "'081 - 360"
TstJ4:
If Range("J4") = "360+" Then GoTo TstNo4
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Range("J4").Select
ActiveCell.FormulaR1C1 = "'360+"
TstNo4:
Range("A4").Select
Selection.End(xlToRight).Offset(0, 1).Select
If ActiveCell.Offset(0, -1) = "Grand Total" Then Exit Sub
Do While ActiveCell = Empty
Selection.EntireColumn.Delete
Loop
End Sub
Sub HeaderRow()
'
' Macro4 Macro
'
'
'
Windows("Top 20 Summary.xls").Activate
Sheets("Summary").Select
Range("A2") = "Customer Name"
Range("B2") = "Customer #"
Range("C2") = "Current"
Range("D2") = "'001-030"
Range("E2") = "'031-060"
Range("F2") = "'061-090"
Range("G2") = "'091-180"
Range("H2") = "'181-360"
Range("I2") = "'360+"
Range("J2") = "Grand Total"
Range("K2") = "Debt"
Range("K1") = "Bad"
Rows("1:2").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Range("K1:K2").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("A2").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1:K2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1:B2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C1") = "Status of Days"
Range("C1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
Range("C1:J2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$3"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = _
"&""Book Antiqua,Bold""&20Summary" & "Top 20 Bad Debt Customers"
.RightHeader = ""
.LeftFooter = "&D" & "&T"
.CenterFooter = "&P of &N"
.RightFooter = "&F"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
Range("A1").Select
End Sub
Sub Schedule_VI()
' Schedule_VI Macro
'
Application.ScreenUpdating = False
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
On Error GoTo 0
Sheets("Receivables by Invoice").Select
Application.StatusBar = "Creating Pivot Table..."
Range("A1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable4"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable4").SmallGrid = False
ActiveSheet.PivotTables("PivotTable4").AddFields
RowFields:=Array("Customer " _
, "Customer Name", "SubBranch"), ColumnFields:="Status of days"
ActiveSheet.PivotTables("PivotTable4").PivotFields("Amount").Orientation
= _
xlDataField
Application.CommandBars("PivotTable").Visible = False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("A:L").EntireColumn.AutoFit
Columns("B:B").Select
Range("A5").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
Range("B7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter Field:=2
Selection.AutoFilter
ActiveSheet.Name = "Schedule VI"
Call Populate_Customer
Columns("D:N").Select
Selection.Style = "Comma"
Range("D3:J3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
.Font.Bold = True
End With
Sub Populate_Customer()
'
Application.ScreenUpdating = False
Windows("Test Receivables.xls").Activate
Sheets("Schedule VI").Select
Range("A5").Select
Again:
If ActiveCell = "Grand Total" Then Exit Sub
Call Schedule_Count
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then GoTo Again
End Sub
Sub Schedule_Count()
'
Do While ActiveCell.Offset(1, 0).Value = Empty
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Skip:
Application.CutCopyMode = False
Loop
End Sub
Sub Clear_End_Month()
'
' Macro1 Macro
'
'
'
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
Sheets("End Month").Select
ActiveWindow.SelectedSheets.Delete
NoMo:
On Error GoTo 0
Range("A1").Select
Windows("Central DATA.xls").Activate
Range("A1").Select
End Sub
Sub EndMonth()
'
' Macro2 Macro
'
'
'
Windows("Test Receivables.xls").Activate
Range("A4:L4").Copy
Sheets.Add.Name = "End Month"
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
AgainLook:
Sheets("Schedule VI").Select
CustomerNo = InputBox(Prompt:="Enter Customer Number")
Range("A5").Select
If CustomerNo = Empty Then GoTo Done
Columns("A:A").Select
On Error GoTo NotListed
Selection.Find(What:=CustomerNo, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Select
Do While ActiveCell.Value = CustomerNo
ActiveCell.Range("A1:J1").Select
Selection.Copy
Sheets("End Month").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Schedule VI").Select
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("End Month").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Done:
Answer = MsgBox(Prompt:="Are there more Entries?", _
Buttons:=vbYesNo + vbQuestion)
If Answer = vbNo Then GoTo CleanUp
GoTo AgainLook
CleanUp:
ActiveCell.Offset(1, 0).Select
Range("N2").FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 13).FormulaR1C1 =
"=RC[-2]-RC[-1]"
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Windows("Central DATA.xls").Activate
Range("L9:N10").Select
Selection.Copy
Windows("Test Receivables.xls").Activate
Sheets("End Month").Select
Range("L2").Select
ActiveSheet.Paste
Range("A4").Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="0"
Range("N4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Selection.AutoFilter Field:=14
Selection.AutoFilter
Columns("A:C").Select
Selection.Font.Bold = True
Rows("3:3").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Range("A1").Select
Call Grand_Sums
Columns("A").EntireColumn.AutoFit
Range("D4").Select
ActiveWindow.FreezePanes = True
Exit Sub
NotListed:
Select Case Err.Number
Case Is = 91
MsgBox "Customer Not Listed"
Resume AgainLook
MsgBox "Customer Not Listed"
GoTo AgainLook
End Select
GoTo CleanUp
NoData:
End Sub
Sub Grand_Sums()
'
' Macro1 Macro
'
'
'
Range("A3").Select
Selection.End(xlDown).Offset(2, 0).Select
ActiveCell.FormulaR1C1 = "Grand Totals"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 10)
Selection.End(xlDown).Offset(2, 10).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 11)
Selection.End(xlDown).Offset(2, 11).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 12)
Selection.End(xlDown).Offset(2, 12).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 13)
Selection.End(xlDown).Offset(2, 13).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
End Sub
Sub TodayDate()
'
' Macro4 Macro
'
'
'
Range("D4").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
End Sub
Customer Name , Status of days. This is for our Accounts Receivables agings ,
that ranges from “Current†through “360†days of money owed to us. This
report is made up of a number of macros that creates a pivot table called
Test Receivables. Once the table is created it fills in the Customer number
and Customer name. The problem is if the Customer has more than one Customer
number it won’t place the name in the next cell . I will list my script ,
but I know I might need to explain further, I just figured I would start
here. The names of the Macros I need help with are (Sub Populate_Customer) &
(Sub Schedule Count). They are about 3 quarters of the way down the page.
Thanks Todd
Sub Receivables_One_Week()
'
' Receivables_One_Week Macro
'
Application.StatusBar = "Importing ......North Central..."
Application.ScreenUpdating = False
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\North Central(08).xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"Test Receivables.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Application.StatusBar = "Importing ......Taylor.........."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\Taylor(06).xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("Taylor(06).xls").Close
Application.StatusBar = "Importing ......South Central......."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\South Central(07).xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("South Central(07).xls").Close
Application.StatusBar = "Importing ......Convenience Works.........."
Workbooks.Open Filename:= _
"\\Bgnhss2kfs01\Reports\AR\Aging by Company\Convenience
Works-Foodservice.xls"
Range("A2:O2").Select
Range(Selection, Selection.End(xlDown)).Copy
Windows("Test Receivables.xls").Activate
ActiveSheet.Paste
Windows("Convenience Works-Foodservice.xls").Close
Application.DisplayAlerts = True
Application.StatusBar = "Creating Report.........."
Windows("Test Receivables.xls").Activate
Range("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("M:N").Select
Selection.Cut Destination:=Columns("P:Q")
Columns("K:K").Select
Selection.Style = "Comma"
Windows("Central DATA.xls").Activate
Sheets("Program").Select
Rows("30:30").Select
Selection.Copy
Windows("Test Receivables.xls").Activate
Rows("1:1").Select
ActiveSheet.Paste
Columns("A
").EntireColumn.AutoFitRange("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 13).FormulaR1C1 =
"='[Central DATA.xls]Program'!R4C4"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).FormulaR1C1 =
"=RC[1]-RC[-8]"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 12).Select
Selection.Style = "Comma"
Columns("O:O").NumberFormat = "@"
Columns("O:O").Select
With Selection
.HorizontalAlignment = xlCenter
End With
' Pivot Table
Application.StatusBar = "Creating Pivot Table..."
Range("A1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable1"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable1").SmallGrid = False
ActiveSheet.PivotTables("PivotTable1").AddFields
RowFields:=Array("SubBranch", _
"Customer Name", "Customer "), ColumnFields:="Status of days"
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With
Application.CommandBars("PivotTable").Visible = False
Columns("A:C").EntireColumn.AutoFit
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("B5").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
Range("B5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter Field:=2
Selection.AutoFilter
Columns("D:L").Select
Selection.Style = "Comma"
Columns("A:L").EntireColumn.AutoFit
Columns("D:K").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
End Sub
Sub SummaryBadDebt()
'
' Macro2 Macro
'
'
Dim Rng As Range
Dim Pth As String
Pth = ThisWorkbook.Path
ChDir Pth
Application.ScreenUpdating = False
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
Range("A1
1").SelectRange(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable2"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").SmallGrid = False
ActiveSheet.PivotTables("PivotTable2").AddFields
RowFields:=Array("SubBranch", _
"Customer Name", "Customer "), ColumnFields:="Status of days"
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With
Sub Pasties()
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A5").Select
' Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
' Range("B5").Select
' Range(Selection, Selection.End(xlDown)).Select
' Selection.EntireRow.Delete
' Selection.AutoFilter Field:=2
' Selection.AutoFilter
' Sorts Status of days
Call FormatDays
' Copies Customer names down to blank cells
Call PopulateCustomerName
' Delets zero Bad Debt rows
Call KillZero
' Subtotal Customer Names for group totals
' Call Subtotalme
' fill copies down of names line
Call RTotal
If ActiveCell <> "" Then GoTo LastOne
Selection.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
LastOne:
End Sub
____________________________________________________________________
Sub PopulateCustomerName()
'
' Application.ScreenUpdating = False
' Windows("Test Receivables.xls").Activate
' Sheets("Schedule VI").Select
Range("B5").Select
Again:
If ActiveCell.Offset(2, -1) = "Grand Total" Then Exit Sub
Call NameCount
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then GoTo Again
End Sub
Sub NameCount()
'
Do While ActiveCell.Offset(1, 0).Value = Empty
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Loop
End Sub
____________________________________________________________________
Sub FormatDays()
Columns("D:L").Select
Selection.Style = "Comma"
Columns("A:L").EntireColumn.AutoFit
Columns("D:K").Select
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""MS Sans Serif,Bold""&12&A" & "&8&F"
.RightHeader = ""
.LeftFooter = "&12&F"
.CenterFooter = "&8&P of &N"
.RightFooter = "&8&D &T"
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
Range("E3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Call FillDays
Columns("D
").EntireColumn.AutoFitWindows("Central Scorecard.xls").Activate
Sheets("Sheet3").Select
Range("L4:L5").Select
Selection.Copy
Windows("Top 20 Summary.xls").Activate
Range("L4").Select
ActiveSheet.Paste
Range("L5").Copy
Range("K6").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("D:O").EntireColumn.AutoFit
End Sub
Sub FillDays()
If Range("E4") = "001 - 030" Then GoTo TstF4
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Range("E4").Select
ActiveCell.FormulaR1C1 = "'000 - 030"
TstF4:
If Range("F4") = "031 - 060" Then GoTo TstG4
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("F4").Select
ActiveCell.FormulaR1C1 = "'031 - 060"
TstG4:
If Range("G4") = "061 - 090" Then GoTo TstH4
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G4").Select
ActiveCell.FormulaR1C1 = "'061 - 090"
TstH4:
If Range("H4") = "091 - 180" Then GoTo TstI4
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H4").Select
ActiveCell.FormulaR1C1 = "'091 - 180"
TstI4:
If Range("I4") = "181 - 360" Then GoTo TstJ4
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Range("I4").Select
ActiveCell.FormulaR1C1 = "'081 - 360"
TstJ4:
If Range("J4") = "360+" Then GoTo TstNo4
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Range("J4").Select
ActiveCell.FormulaR1C1 = "'360+"
TstNo4:
Range("A4").Select
Selection.End(xlToRight).Offset(0, 1).Select
If ActiveCell.Offset(0, -1) = "Grand Total" Then Exit Sub
Do While ActiveCell = Empty
Selection.EntireColumn.Delete
Loop
End Sub
Sub HeaderRow()
'
' Macro4 Macro
'
'
'
Windows("Top 20 Summary.xls").Activate
Sheets("Summary").Select
Range("A2") = "Customer Name"
Range("B2") = "Customer #"
Range("C2") = "Current"
Range("D2") = "'001-030"
Range("E2") = "'031-060"
Range("F2") = "'061-090"
Range("G2") = "'091-180"
Range("H2") = "'181-360"
Range("I2") = "'360+"
Range("J2") = "Grand Total"
Range("K2") = "Debt"
Range("K1") = "Bad"
Rows("1:2").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Range("K1:K2").Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Range("A2").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1:K2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1:B2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C1") = "Status of Days"
Range("C1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
Range("C1:J2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$3"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = _
"&""Book Antiqua,Bold""&20Summary" & "Top 20 Bad Debt Customers"
.RightHeader = ""
.LeftFooter = "&D" & "&T"
.CenterFooter = "&P of &N"
.RightFooter = "&F"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
Range("A1").Select
End Sub
Sub Schedule_VI()
' Schedule_VI Macro
'
Application.ScreenUpdating = False
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
On Error GoTo 0
Sheets("Receivables by Invoice").Select
Application.StatusBar = "Creating Pivot Table..."
Range("A1:O1").Select
Range(Selection, Selection.End(xlDown)).Select
Set Rng = Range(Selection, Selection.End(xlDown))
Rng.Name = "Data"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Data").CreatePivotTable TableDestination _
:="", TableName:="PivotTable4"
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable4").SmallGrid = False
ActiveSheet.PivotTables("PivotTable4").AddFields
RowFields:=Array("Customer " _
, "Customer Name", "SubBranch"), ColumnFields:="Status of days"
ActiveSheet.PivotTables("PivotTable4").PivotFields("Amount").Orientation
= _
xlDataField
Application.CommandBars("PivotTable").Visible = False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("A:L").EntireColumn.AutoFit
Columns("B:B").Select
Range("A5").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="=*total*", Operator:=xlAnd
Range("B7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Selection.AutoFilter Field:=2
Selection.AutoFilter
ActiveSheet.Name = "Schedule VI"
Call Populate_Customer
Columns("D:N").Select
Selection.Style = "Comma"
Range("D3:J3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
.Font.Bold = True
End With
Sub Populate_Customer()
'
Application.ScreenUpdating = False
Windows("Test Receivables.xls").Activate
Sheets("Schedule VI").Select
Range("A5").Select
Again:
If ActiveCell = "Grand Total" Then Exit Sub
Call Schedule_Count
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then GoTo Again
End Sub
Sub Schedule_Count()
'
Do While ActiveCell.Offset(1, 0).Value = Empty
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Skip:
Application.CutCopyMode = False
Loop
End Sub
Sub Clear_End_Month()
'
' Macro1 Macro
'
'
'
On Error GoTo NoMo
Windows("Test Receivables.xls").Activate
Sheets("End Month").Select
ActiveWindow.SelectedSheets.Delete
NoMo:
On Error GoTo 0
Range("A1").Select
Windows("Central DATA.xls").Activate
Range("A1").Select
End Sub
Sub EndMonth()
'
' Macro2 Macro
'
'
'
Windows("Test Receivables.xls").Activate
Range("A4:L4").Copy
Sheets.Add.Name = "End Month"
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
AgainLook:
Sheets("Schedule VI").Select
CustomerNo = InputBox(Prompt:="Enter Customer Number")
Range("A5").Select
If CustomerNo = Empty Then GoTo Done
Columns("A:A").Select
On Error GoTo NotListed
Selection.Find(What:=CustomerNo, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Select
Do While ActiveCell.Value = CustomerNo
ActiveCell.Range("A1:J1").Select
Selection.Copy
Sheets("End Month").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Schedule VI").Select
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("End Month").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Done:
Answer = MsgBox(Prompt:="Are there more Entries?", _
Buttons:=vbYesNo + vbQuestion)
If Answer = vbNo Then GoTo CleanUp
GoTo AgainLook
CleanUp:
ActiveCell.Offset(1, 0).Select
Range("N2").FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 13).FormulaR1C1 =
"=RC[-2]-RC[-1]"
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Windows("Central DATA.xls").Activate
Range("L9:N10").Select
Selection.Copy
Windows("Test Receivables.xls").Activate
Sheets("End Month").Select
Range("L2").Select
ActiveSheet.Paste
Range("A4").Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="0"
Range("N4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Selection.AutoFilter Field:=14
Selection.AutoFilter
Columns("A:C").Select
Selection.Font.Bold = True
Rows("3:3").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Range("A1").Select
Call Grand_Sums
Columns("A
").EntireColumn.AutoFitRange("D4").Select
ActiveWindow.FreezePanes = True
Exit Sub
NotListed:
Select Case Err.Number
Case Is = 91
MsgBox "Customer Not Listed"
Resume AgainLook
MsgBox "Customer Not Listed"
GoTo AgainLook
End Select
GoTo CleanUp
NoData:
End Sub
Sub Grand_Sums()
'
' Macro1 Macro
'
'
'
Range("A3").Select
Selection.End(xlDown).Offset(2, 0).Select
ActiveCell.FormulaR1C1 = "Grand Totals"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 10)
Selection.End(xlDown).Offset(2, 10).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 11)
Selection.End(xlDown).Offset(2, 11).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 12)
Selection.End(xlDown).Offset(2, 12).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
Range("A4").Select
Set Rng = Range(ActiveCell, ActiveCell.End(xlDown)).Offset(0, 13)
Selection.End(xlDown).Offset(2, 13).Select
ActiveCell.Formula = "=SUM(" & Rng.Address & ")"
Selection.Style = "Comma"
End Sub
Sub TodayDate()
'
' Macro4 Macro
'
'
'
Range("D4").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
End Sub