Split Worksheet to Multiple Worksheets

[markoakes]

I have a worksheet that has data in columns A to N. The Salesman’s number is in column A and I need to split this first worksheet in to separate worksheets in the same workbook for each salesman.

 

[VoG]

Try changing the line in red.

Sub ZipsToSheet()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, j As Integer
Application.ScreenUpdating = False
With Sheets("FINAL_TABLE")
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets

 

[SLKGVILLE]

That did the trick!! You've been a HUGE help! Thanks.

 

[SLKGVILLE]

Is there a way to keep specific sheets within a workbook from getting deleted by a macro. I'm running the first macro in red to break up Zipcodes and then the second macro in blue to break up Routes. Everything works great but when I make a change to the Route and run the macro in blue, it deletes my Zipcode sheets. Thanks!!

Sub zip_split()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, j As Integer
Application.ScreenUpdating = False
With Sheets("FINAL_TABLE")
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
Next ws
Application.DisplayAlerts = True
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:=Range("C2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("C" & i).Value <> .Range("C" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("C" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
With ws.Rows(1)
.HorizontalAlignment = xlCenter
With .Font
.ColorIndex = 5
.Bold = True
End With
End With
For j = 1 To 4
ws.Cells(2, j).Value = .Cells(iStart, j).Value
Next j
For j = 5 To 52
If j <> 8 And j <> 9 Then
ws.Cells(2, j).Value = WorksheetFunction.Sum(.Range(.Cells(iStart, j), .Cells(iEnd, j)))
End If
Next j
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Sub GVILLE()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheets("FINAL_TABLE")
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> .Name Then ws.Delete
Next ws
Application.DisplayAlerts = True
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:=Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("A" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
With ws.Rows(1)
.HorizontalAlignment = xlCenter
With .Font
.ColorIndex = 5
.Bold = True
End With
End With
.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
End Sub

 

[VoG]

Try deleting the lines in blue. You should then get prompted before the sheets get deleted

Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> .Name Then ws.Delete
Next ws
Application.DisplayAlerts = True

 

[msnorbury]

VoG,

2007 and 2010/windows

I am sorry for responding and not referencing this post. My problem is almost the same but I need to reference col. "U" instead of "A". I have been playing with the program above and best I could do is to copy my information over to "A".
I also need all information from the row moved over to the new sheet instead of just the reference cell.

One last item if it's not to big of a problem is the need to bring over all values and formating from rows 1-10 without a command button that is in sheet 1 and freeze between 10 and 11.

Again I am sorry for the private. New to this and still stumbling along. I can't believe you guys can do this.

 

[VoG]

Is this any good?

Sub USort()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    LastRow = .Cells(Rows.Count, "U").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Range("U2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LastRow
        If .Range("U" & i).Value <> .Range("U" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("U" & iStart).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
End Sub

 

[msnorbury]

Hi Vog.

It's getting hung up at what I believe is a sort command.

.Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Range("U2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Having the top 10 rows in use may be a problem and col A is blank.

The initial input is coming from a form. If I knew how to attach the file I would.
Would it help if I sent it to you?

 

[VoG]

Maybe

Sub USort()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    LastRow = .Cells(Rows.Count, "U").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(11, 2), .Cells(LastRow, LastCol)).Sort Key1:=.Range("U12"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 11
    For i = iStart To LastRow
        If .Range("U" & i).Value <> .Range("U" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("U" & iStart).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
End Sub

If not please start a new thread as this one is old and your question appears to be different.

 

[msnorbury]

Still trying to get it. I was wrong and the data starts on row 10. A1:W10 need to transfer to each new sheet and then all rows for that sheet. I was thinking of something like copy sheet1 to end and then delete those items that don't match. that way the format would be there and would just have to get rid of the command button that shows at the top.

I don't understand the sort being the reason for the trouble unless some cells don't have items in them. Rows are populated from a form and may not know value of "U" at time of fill so it will be blank.

maybe I should explain. info is populated from a form across the row, B-W with click of button. if value in "U" has a sheet add copy full row to that sheet, if not make new sheet.

If the values of some or all rows for "U" are not known at input time they will need to be updated with an update command without dupes. Can just overwrite.

Does this help

 

[msnorbury]

VoG

I was looking at the post we started at and it's not the same I originally found.

Here is the Code I have Been attempting to work with.

Sub deviceNewSheet()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(10, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(10, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("A10"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("A" & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(10, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            With ws.Rows(1)
                .HorizontalAlignment = xlCenter
                With .Font
                    .ColorIndex = 5
                    .Bold = True
                End With
            End With
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A10")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Although the information and formatting from "A1:W9" do not show on the new sheets.
Also still have a sheet that gives just a sheet name. Source value is RO/PROCESS WATER. Don't know if that matters.

Trying to help, learn and understand.