Sub SalesmanToSheet()
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(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
Option Explicit
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
' column G has the criteria eg project ref
wsAll.Range("G1:G" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
Set wsNew = Worksheets.Add
wsNew.Name = wsCrit.Range("A2")
wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
End Sub
This piece of code is awesome!! I have one issue. I have this code splitting out column A which is named "Route". There are 20 routes which means it created 20 new sheets for me. The Route will be changing some. So when the user changes the route and runs the macro, how do I get it to overwrite the 20 sheets that were created? When I update the master sheet and run the macro it wont overwrite the 20 sheets it just creates an additional 20. Any help will be GREATLY appreciated!!!Try this with your sheet selected:
Code:Sub SalesmanToSheet() 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(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
This piece of code is awesome!! I have one issue. I have this code splitting out column A which is named "Route". There are 20 routes which means it created 20 new sheets for me. The Route will be changing some. So when the user changes the route and runs the macro, how do I get it to overwrite the 20 sheets that were created? When I update the master sheet and run the macro it wont overwrite the 20 sheets it just creates an additional 20. Any help will be GREATLY appreciated!!!
Yes, the workbook contains the "master" sheet plus the 20 sheets created by the macro. The only sheet that doesnt need to be deleted is the "master" of course. If I make a change to the Route and run the macro I would be happy just to overwrite everything but the master or just update what was changed. Thank you so much for your quick response!!!Does the workbook just contain the "master" sheet plus the 20 created by the macro? If not, what are the names of the sheets that must not be deleted (including the "master" sheet).
Sub SalesmanToSheet()
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
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