Option Explicit
'----------------------------------------------
'Enter these constant values for your sheet setup
'Example: Column "C" is 3
Const COLUMN_SENDER_COMPANY_NAME As Integer = 4
Const COLUMN_PICKUP_DATE As Integer = 3
Const ROW_WITH_HEADERS As Integer = 1
'----------------------------------------------
Sub FilterForExcessShipments()
Dim lRow As Long
Dim lCol As Long
Dim wb As Workbook
Dim wsSource As Worksheet
Dim x As Long
'References to sheets and ensure no hidden columns or autofilters
Set wsSource = Activesheet
Set wb = Workbooks.Add
wb.Sheets(1).Name = "StoreList"
wsSource.Activate
wsSource.AutoFilterMode = False
wsSource.Columns.Hidden = False
'Get last Row
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
'Remove Prior Count Column if it exists (if we ran this before)
If Cells(ROW_WITH_HEADERS, lCol).Value = "COUNT" Then
Cells(ROW_WITH_HEADERS, lCol).EntireColumn.Delete
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
End If
'Create Array Formula in column to right of data
'This line cound be deleted if the formula was always there already
Call CreateArrayFormulaInColumnToRight(lRow, lCol)
'Autofilter
'Variable lCol assumes the array formula is in the last column
Range(Cells(ROW_WITH_HEADERS, 1), Cells(lRow, lCol)).AutoFilter _
Field:=lCol, Criteria1:=">1", Operator:=xlAnd
'copy to new workbook (on row 1)
Cells(ROW_WITH_HEADERS, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
wb.Sheets(1).Activate
Cells(ROW_WITH_HEADERS, 1).PasteSpecial
Application.CutCopyMode = False
'Delete array formula
With wb.Sheets(1)
For x = 1 To .Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
If UCase(.Cells(ROW_WITH_HEADERS, x).Value) = "COUNT" Then
.Cells(ROW_WITH_HEADERS, x).EntireColumn.Delete
Exit For
End If
Next x
End With
'Hide columns and add new columns to newly created sheet
Call TakeOutColumns(wb, wb.Sheets(1), True)
Call TakeOutColumns(ActiveWorkbook, wsSource, False)
'Clean up new workbook
Call MyColumnWidths(wb.Sheets(1))
wsSource.Activate
Call NewSheetWithSubtotals(wb.Sheets(1))
wsSource.Activate
Application.CutCopyMode = False
End Sub
'----------------------------------------------
Private Sub CreateArrayFormulaInColumnToRight(ByVal lRow As Long, ByRef lCol As Long)
Dim strMyFormula As String
Dim colSender As Integer
Dim colDate As Integer
Dim rHeaders As Integer
'Just in case
Activesheet.AutoFilterMode = False
'to make it easier to read the formula
colSender = COLUMN_SENDER_COMPANY_NAME
colDate = COLUMN_PICKUP_DATE
rHeaders = ROW_WITH_HEADERS
'Code enters array formula in empty column to the right
'this column will be called "COUNT"
'Header
Cells(rHeaders, lCol + 1).Value = "COUNT"
'Formula
strMyFormula = "=SUM((R" & rHeaders + 1 & "C" & colDate & ":" _
& "R" & lRow & "C" & colDate & "=" & "R" & "C[" & -1 * (lCol + 1 - colDate) & "])" _
& "*" & _
"(R" & rHeaders + 1 & "C" & colSender & ":" & _
"R" & lRow & "C" & colSender & "=" & "R" & "C[" & -1 * (lCol + 1 - colSender) & "])" & _
"*1)"
'Debug
Debug.Print "=SUM((R2C3:R24C3=RC[-2])*(R2C4:R24C4=RC[-1])*1)"
Debug.Print strMyFormula
'Enter formulas
Cells(rHeaders + 1, lCol + 1).FormulaArray = strMyFormula
Cells(rHeaders + 1, lCol + 1).Copy Destination:=Range(Cells(rHeaders + 2, lCol + 1), Cells(lRow, lCol + 1))
'reset lCol
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
End Sub
'----------------------------------------------
Private Sub TakeOutColumns(ByRef Arg1 As Workbook, ByRef Arg2 As Worksheet, _
ByVal Arg3 As Boolean)
Dim ws As Worksheet
Dim lCol As Long
Dim strTest As String
Dim x As Long
Dim y As Byte
Dim myArray(1 To 3)
'Reference calling sheet and activate sheet for this routine
Set ws = Activesheet
Arg1.Activate
Arg2.Activate
'New column headers to be added
myArray(1) = "Chg Amt"
myArray(2) = "Acct #"
myArray(3) = "Actual Pickup Date"
If Arg3 = True Then
'To add new columns for user to fill in later
'Adds three columns to the right of "Sender Zip"
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
For x = lCol To 1 Step -1
If UCase(Cells(ROW_WITH_HEADERS, x).Value) = "SENDER ZIP" Then
For y = 1 To 3
Columns(x + 1).Insert Shift:=xlToRight
Cells(ROW_WITH_HEADERS, x + 1).Value = myArray(y)
Next y
End If
Next x
End If
'To hide columns that are to be hidden
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
For x = lCol To 1 Step -1
Select Case Trim(UCase(CStr(Cells(ROW_WITH_HEADERS, x).Value)))
Case Is = "TRACKING NUMBER", "PICKUP DATE", "SENDER COMPANY NAME", _
"SENDER ZIP", "RECEIVER CITY", "CHG AMT", "ACCT #", "ACTUAL PICKUP DATE"
Case Else
Columns(x).Hidden = True
End Select
Next x
'Return to calling sheet
ws.Activate
End Sub
'----------------------------------------------
Private Sub MyColumnWidths(ByRef Arg1 As Worksheet)
Dim lCol As Long
Dim x As Long
Dim ws As Worksheet
Set ws = Activesheet
Arg1.Activate
Columns.AutoFit
lCol = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column
For x = lCol To 1 Step -1
If Columns(x).ColumnWidth < 10 Then
Columns(x).ColumnWidth = 10
End If
Next x
Cells(ROW_WITH_HEADERS, 1).Activate
Application.CutCopyMode = False
ws.Activate
End Sub
'----------------------------------------------
Private Sub NewSheetWithSubtotals(Arg1 As Worksheet)
Dim x As Long
Const IN_A_NEW_WORKBOOK As Boolean = True
'Set the above constant equal to false if you want a second subtotals sheet
'in the same workbook instead of in a new workbook
Arg1.Activate
If IN_A_NEW_WORKBOOK Then
Arg1.Copy
Activesheet.Name = "ForSubtotals"
Else
Arg1.Copy After:=Arg1
Activesheet.Name = "ForSubtotals"
End If
'Since we are working off the sheet with the columns added, take them back out
For x = Cells(ROW_WITH_HEADERS, Columns.Count).End(xlToLeft).Column To 1 Step -1
If WorksheetFunction.CountA(Columns(x)) = 1 Then
Columns(x).Delete
End If
Next x
'Sort by Sender company
Cells(ROW_WITH_HEADERS, COLUMN_SENDER_COMPANY_NAME).CurrentRegion.Sort _
Key1:=Cells(ROW_WITH_HEADERS, COLUMN_SENDER_COMPANY_NAME), Order1:=xlAscending, Header:=xlGuess
End Sub
'----------------------------------------------
Sub MyTestMyFilterForExcessShipments()
Dim wb As Workbook
Dim ans As Integer
Dim msg As String
msg = "This sub deletes all open workbooks with names like Book1, Book2, etc." & vbCrLf & vbCrLf
msg = msg & "Continue?"
ans = MsgBox(msg, vbOKCancel)
If ans <> vbOK Then End
For Each wb In Workbooks
If Left(wb.Name, 4) = "Book" Then
wb.Close SaveChanges:=False
End If
Next wb
Call FilterForExcessShipments
End Sub
'----------------------------------------------
Sub MyTestMyNewSheetsWithSubtotals()
Dim ws As Worksheet
Dim xRay As Worksheet
Dim x As Integer
x = 1
Set xRay = Activesheet
For Each ws In Worksheets
If ws.Name = "Subtotals" Then
ws.Name = ws.Name & Format(Now, "_Hh_Nn_Ss")
End If
Next ws
xRay.Activate
Call NewSheetWithSubtotals(xRay)
End Sub
Let me know how it works. I've deleted the count in the export because this is really not useful data anymore--if you sum it up its not a real count, because the total duplicates on every row (I'll study a few Aladin Akyurek posts and see if I can figure out a formula for a running total 
ray: ).
Again, change the constants for the correct relative columns and rows, and do not put the array formula in yourself. (But if you do you can just delete the line of code that is a call to the createArray routine)
