Hello,
I need to split a worksheet into new workshets in the same workbook using customer names in column D which includes subtotals. However, the macro i am using splits the customer name and customer subtotal into different sheets as the customer name now contains "total" so the macro doesn't recognize this is the same customer.
E.G
Customer name
Kwik Fit
Kwit Fit Subtotal
Mail Marketing
Mail Marketing Subtotal
I need the macro to split the above customer names so that the customer name including the subtotal gets split into a new worksheet AND the new worksheet is named after the customer name.
I am aware their are add ins for such tasks but i am using this at work and cannot install any files.
http://www.mrexcel.com/forum/showthread.php?t=396069
Sub Lapta() Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long Dim ws As Worksheet, r As Range, iCol As Integer, t As Date On Error Resume Next Set r = Application.InputBox("Click in the column to extract by", Type:=8) On Error GoTo 0 If r Is Nothing Then Exit Sub iCol = r.Column t = Now Application.ScreenUpdating = False With ActiveSheet lastrow = .Cells(Rows.Count, "A").End(xlUp).Row LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom iStart = 2 For i = 2 To lastrow If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then iEnd = i Sheets.Add after:=Sheets(Sheets.Count) Set ws = ActiveSheet On Error Resume Next ws.Name = .Cells(iStart, iCol).Value On Error GoTo 0 ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2") iStart = iEnd + 1 End If Next i End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation End Sub</pre>
I appreciate any help anyone can give - i'm currently trying to learn VBA but this one is a tough nut to crack! Need some help
Thanks in advance
Aldo
I need to split a worksheet into new workshets in the same workbook using customer names in column D which includes subtotals. However, the macro i am using splits the customer name and customer subtotal into different sheets as the customer name now contains "total" so the macro doesn't recognize this is the same customer.
E.G
Customer name
Kwik Fit
Kwit Fit Subtotal
Mail Marketing
Mail Marketing Subtotal
I need the macro to split the above customer names so that the customer name including the subtotal gets split into a new worksheet AND the new worksheet is named after the customer name.
I am aware their are add ins for such tasks but i am using this at work and cannot install any files.
http://www.mrexcel.com/forum/showthread.php?t=396069
Sub Lapta() Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long Dim ws As Worksheet, r As Range, iCol As Integer, t As Date On Error Resume Next Set r = Application.InputBox("Click in the column to extract by", Type:=8) On Error GoTo 0 If r Is Nothing Then Exit Sub iCol = r.Column t = Now Application.ScreenUpdating = False With ActiveSheet lastrow = .Cells(Rows.Count, "A").End(xlUp).Row LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom iStart = 2 For i = 2 To lastrow If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then iEnd = i Sheets.Add after:=Sheets(Sheets.Count) Set ws = ActiveSheet On Error Resume Next ws.Name = .Cells(iStart, iCol).Value On Error GoTo 0 ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2") iStart = iEnd + 1 End If Next i End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation End Sub</pre>
I appreciate any help anyone can give - i'm currently trying to learn VBA but this one is a tough nut to crack! Need some help
Thanks in advance
Aldo
Last edited:
