I don't see that pastespecial line anymore????
This may get you closer.
It does an advancedfilter on column L to a new worksheet. Then it cycles
through those values and does an autofilter based on each--then it copies each
row--one at a time to the new location.
You may have to apply some formatting to the output--columnwidths for example.
Option Explicit
Sub Break_Up_Master()
Dim wks As Worksheet
Dim tempWks As Worksheet
Dim newWks As Worksheet
Dim myUniqueRng As Range
Dim myKeyCol As Range
Dim myCell As Range
Dim myRow As Range
Dim DestCell As Range
Set wks = Worksheets("Macro for wb")
Set tempWks = Worksheets.Add
Set myKeyCol = wks.Range("L1").EntireColumn
myKeyCol.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=tempWks.Range("a1"), Unique:=True
With tempWks
Set myUniqueRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With wks
For Each myCell In myUniqueRng.Cells
.AutoFilterMode = False
myKeyCol.AutoFilter field:=1, Criteria1:=myCell.Value
'try to delete old sheet
Application.DisplayAlerts = False
On Error Resume Next
.Parent.Worksheets(myCell.Value).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'create the newsheet and move it far right
Set newWks = .Parent.Worksheets.Add
newWks.Move after:=.Parent.Worksheets(.Parent.Worksheets.Count)
On Error Resume Next
newWks.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & newWks.Name & " manually!"
Err.Clear
End If
On Error GoTo 0
'copy and paste row by row.
Set DestCell = newWks.Range("A1")
For Each myRow In .AutoFilter.Range.Columns(1) _
.Cells.SpecialCells(xlCellTypeVisible).EntireRow
myRow.Copy _
Destination:=DestCell
Set DestCell = DestCell.Offset(1, 0)
Next myRow
Next myCell
.AutoFilterMode = False
End With
'delete that temp worksheet
Application.DisplayAlerts = False
tempWks.Delete
Application.DisplayAlerts = True
End Sub
Here's the code I'm trying to use and keep my formulas. If I did paste the
formulas lline by line, would I paste them after the advanced filter? And how
would I reference the row if I don't know where it is in the worksheet? I
need to sign up for a class: I really like working with macros but I don't
know enough to fly alone.
Sub Break_Up_Master()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Macro for wb")
Set rng = Range("Budvars")
'extract a list of Sales Reps
ws1.Columns("A:A").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row
'set up Criteria Area
Range("L1").Value = Range("A1").Value
For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Macro for wb").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move after:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Macro for wb").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
