Using the result of autofilter and performing tasks on each value
 

I am performing an auto filter on a sheet where column B is a list of
sales people. For each sales person in the list I would like to copy
the data into a new worksheet that is named the same as the salesperson.

For some reason I can create the new sheets with the proper name but
cannot get the data to copy starting at cell A4.
Can anyone help, PLEASE. Thanks



Option Explicit

Sub PAY3()
Dim masterWB As Workbook
Dim newWB As Workbook
Dim filterRange As Range
Dim cell As Range
Dim ws As Worksheet
Dim newSheetName As String
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set masterWB = ThisWorkbook
With masterWB
With ActiveSheet
' create a temporary list of unique SALESPERSONS
.Range("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
' loop through each of the unique SALESPERSONS
' and filter on that value
Set filterRange = .Range("iv2:iv" &
.Range("iv2").End(xlDown).Row)
For Each cell In filterRange
With .Range("A1")
' filter on column B (field:=2)
.AutoFilter Field:=2, Criteria1:=cell
newSheetName = cell.Value
' copy the current range, visible cells
.CurrentRegion.Copy

Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = newSheetName
End With
Sheets(newSheetName).Select


' paste the data
ActiveSheet.Paste

.AutoFilter
Application.CutCopyMode = False
End With
Next 'cell
' clear the temporary list of unique SALESPERSONS
filterRange.Offset(-1, 0).Resize( _
filterRange.Rows.Count + 1, filterRange.Columns.Count).Clear
End With
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

Using the result of autofilter and performing tasks on each value
 

Hi Elinor

Turn of Autofilter and use the last macro on this Page
http://www.rondebruin.nl/copy5.htm

Post back if you need help

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Elinor Hartman" wrote in message ...

I am performing an auto filter on a sheet where column B is a list of
sales people. For each sales person in the list I would like to copy
the data into a new worksheet that is named the same as the salesperson.

For some reason I can create the new sheets with the proper name but
cannot get the data to copy starting at cell A4.
Can anyone help, PLEASE. Thanks



Option Explicit

Sub PAY3()
Dim masterWB As Workbook
Dim newWB As Workbook
Dim filterRange As Range
Dim cell As Range
Dim ws As Worksheet
Dim newSheetName As String
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set masterWB = ThisWorkbook
With masterWB
With ActiveSheet
' create a temporary list of unique SALESPERSONS
.Range("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
' loop through each of the unique SALESPERSONS
' and filter on that value
Set filterRange = .Range("iv2:iv" &
Range("iv2").End(xlDown).Row)
For Each cell In filterRange
With .Range("A1")
' filter on column B (field:=2)
.AutoFilter Field:=2, Criteria1:=cell
newSheetName = cell.Value
' copy the current range, visible cells
.CurrentRegion.Copy

Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = newSheetName
End With
Sheets(newSheetName).Select


' paste the data
ActiveSheet.Paste

.AutoFilter
Application.CutCopyMode = False
End With
Next 'cell
' clear the temporary list of unique SALESPERSONS
filterRange.Offset(-1, 0).Resize( _
filterRange.Rows.Count + 1, filterRange.Columns.Count).Clear
End With
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!