Hi, thanks for your help. For some reason it is still not working. Here is the complete VBA with highlighted areas.
Dim i As Integer 'Scans down Rows Data Sheet
Dim j As Integer 'Prints on New Workbooks
Dim z As String
Dim relativepath As String 'The Directory to save the files to
Dim Count As Integer
Dim Vendor As String
Dim WB As Workbook
Set WB = ActiveWorkbook 'References This Workbook
Dim WS As Worksheet
Set WS = ActiveSheet 'References this Worksheet
Dim WB1 As Workbook 'Assigned to Workbooks being created
Dim WS2 As Worksheet
Count = 0
z = InputBox("Which Month and Year", "Ex 'October-2014'")
'Find Size of List
ListSize = 3
Do Until WS.Cells(ListSize, 1).Value = Empty
ListSize = ListSize + 1
Loop
VendorCount = 0
i = 3
Vendor = WS.Cells(i, 1).Value
Do Until WS.Cells(i, 1).Value = Empty
Vendor = WS.Cells(i, 1).Value
VendorCount = VendorCount + 1
j = 3
'Create the New Workbook
Set WB1 = Workbooks.Add
'Copy OverSheet into NewWorkbook
WS.Copy Before:=WB1.Sheets(1)
WB1.Sheets(1).Name = Vendor
'Trim to Until Vendor Starts
If i > 3 Then
WB1.Sheets(1).Range("A" & j & ":A" & (i - 1)).EntireRow.Delete
End If
'Keep the Vendor Rows and Count
Do Until WB1.Sheets(1).Cells(j, 1) <> Vendor Or _
WB1.Sheets(1).Cells(j, 1) = Empty
j = j + 1
i = i + 1
Count = Count + 1
Loop
'Trim the Rest
WB1.Sheets(1).Range("A" & j & ":A" & ListSize).EntireRow.Delete
'Add Formatting. Start with One Cell then Paste Special the whole row
WB1.Sheets(1).Range("A" & j).Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'Paste Special
WB1.Sheets(1).Range("A" & j).Copy
WB1.Sheets(1).Range("A" & j & ":AO" & j).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Merge Grand Totals
WB1.Sheets(1).Range("A" & j & ":F" & j).Merge
WB1.Sheets(1).Range("A" & j & ":F" & j).Value = "Grand Total"
WB1.Sheets(1).Range("A" & j & ":F" & j).HorizontalAlignment = xlCenter
'Add Subtotals
WB1.Sheets(1).Cells(j, 4).Font.Bold = True
WB1.Sheets(1).Cells(j, 4) = "Grand Total"
WB1.Sheets(1).Cells(j, 7).Formula = "=SUM(G3:G" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 8).Formula = "=SUM(H3:H" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 9).Formula = "=SUM(I3:I" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 10).Formula = "=SUM(J3:J" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 11).Formula = "=SUM(K3:K" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 12).Formula = "=SUM(L3:L" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 13).Formula = "=l" & j & "/K" & j
WB1.Sheets(1).Cells(j, 13).NumberFormat = "0.00%"
WB1.Sheets(1).Cells(j, 14).Formula = "=SUM(N3:N" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 15).Formula = "=SUM(O3:O" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 17).Formula = "=SUM(Q3:Q" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 18).Formula = "=SUM(R3:R" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 19).Formula = "=SUM(S3:S" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 20).Formula = "=SUM(T3:T" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 21).Formula = "=SUM(U3:U" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 22).Formula = "=SUM(V3:V" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 23).Formula = "=v" & j & "/U" & j
WB1.Sheets(1).Cells(j, 23).NumberFormat = "0.00%"
WB1.Sheets(1).Cells(j, 24).Formula = "=SUM(x3:x" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 25).Formula = "=SUM(Y3:Y" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 27).Formula = "=SUM(AA3:AA" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 28).Formula = "=SUM(AB3:AB" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 29).Formula = "=SUM(AC3:AC" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 30).Formula = "=SUM(AD3:AD" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 31).Formula = "=SUM(AE3:AE" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 32).Formula = "=SUM(AF3:AF" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 33).Formula = "=AF" & j & "/AE" & j
WB1.Sheets(1).Cells(j, 33).NumberFormat = "0.00%"
WB1.Sheets(1).Cells(j, 34).Formula = "=SUM(AH3:AH" & (j - 1) & ")"
WB1.Sheets(1).Cells(j, 35).Formula = "=SUM(AI3:AI" & (j - 1) & ")"
'Add Subtotals
Application.DisplayAlerts = False
WB1.Sheets(2).Delete
'WB1.Sheets(2).Delete
'WB1.Sheets(2).Delete
Application.DisplayAlerts = True
'Save the New Workbook to Current Directory
relativepath = WB.Path & "\" & "Independent Store Sales Summary - " & Replace(Vendor, ".", "") & " - " & z
WB1.SaveAs Filename:=relativepath
WB1.Close
Loop
MsgBox (VendorCount & " Vendor Files Printed")
MsgBox ((ListSize - 3) & " items on file, " & Count & " items printed")
End Sub
