Hi Mark
Place these two Files in the same Folder. Workbook Schenker Customer list.xlsx can be open or closed, the Code will open it if required. With regard to Schenker Customer list.xlsx, please note the Grouping by Number. If you have additional Groupings change this line of Code
For i = 0 To 7 '<------ Change this Line for additional Groupings
Run the Code from Schenker 28.11.2013 v3.xlsm...CTRL + x will fire the Code.
Let me know of issues...
Option Explicit
Sub Split_Billings()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, i As Long, j As Long, r As Long
Dim rng2 As Range, cel2 As Range
Dim myPath As String
Dim wasOpen As Boolean
Dim var1 As Variant
Dim sArray() As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets(Sheet1.Name)
myPath = wb1.Path & "\"
With ws1
lr1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End With
On Error Resume Next
Set wb2 = Workbooks("Schenker Customer list.xlsx")
On Error GoTo 0
Application.ScreenUpdating = False
If wb2 Is Nothing Then
Set wb2 = Workbooks.Open(myPath & "Schenker Customer list.xlsx")
Else
wasOpen = True
End If
Set ws2 = wb2.Sheets("Customer List")
With ws2
lr2 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Not .AutoFilterMode Then
.Range("A3").AutoFilter
End If
For i = 0 To 7 '<------ Change this Line for additional Groupings
.Range("A3:F" & lr2).AutoFilter Field:=6, Criteria1:=i
Select Case i
Case Is > 0
var1 = .Range("A3:A" & lr2).SpecialCells(xlCellTypeVisible).Value
ReDim sArray(1 To UBound(var1))
For j = 1 To (UBound(var1))
sArray(j) = var1(j, 1)
Next
ws1.Range("$N$41:$N$" & lr1).AutoFilter Field:=1, Criteria1:=sArray, Operator:=xlFilterValues
r = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Row
ws1.Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = .Cells(r, "B").Value
ActiveSheet.Name = .Cells(r, "B").Value
ActiveSheet.Range("A19").Value = .Cells(r, "C").Value
ActiveSheet.Range("A20").Value = .Cells(r, "D").Value
ActiveSheet.Range("A21").Value = .Cells(r, "E").Value
ActiveSheet.Range("K36").Value = .Cells(r, "A").Value
ActiveSheet.Range("K34").Formula = "=SubTotal(109,G44:G" & lr1 & ")"
ActiveSheet.Range("E34").Formula = "=SubTotal(109,F44:F" & lr1 & ")"
Case Else
Set rng2 = .Range("A3:A" & lr2).SpecialCells(xlCellTypeVisible)
For Each cel2 In rng2
r = cel2.Row
ws1.Range("$N$41:$N$" & lr1).AutoFilter Field:=1, Criteria1:=cel2.Value, Operator:=xlFilterValues
ws1.Copy Before:=wb1.Sheets(1)
ActiveSheet.Name = .Cells(r, "B").Value
ActiveSheet.Range("A19").Value = .Cells(r, "C").Value
ActiveSheet.Range("A20").Value = .Cells(r, "D").Value
ActiveSheet.Range("A21").Value = .Cells(r, "E").Value
ActiveSheet.Range("K36").Value = .Cells(r, "A").Value
ActiveSheet.Range("K34").Formula = "=SubTotal(109,G44:G" & lr1 & ")"
ActiveSheet.Range("E34").Formula = "=SubTotal(109,F44:F" & lr1 & ")"
Next cel2
End Select
Next i
.ShowAllData
End With
With ws1
.ShowAllData
.Activate
End With
End Sub
Bookmarks