P
puiuluipui
Hi, i need the below macro to work even if in sheet1 i insert a row at the
top. Now, the datas begin from row 1. I need this macro to work if the data
start from row 2, and row 1 is empty.
Macro:
Sub ExtractReps()
Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Dim NextRow
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database1")
'extract a list of Sales Reps
ws1.Columns("F:F").Copy _
Destination:=Range("P1")
ws1.Columns("P").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("N1"), Unique:=True
r = Cells(Rows.Count, "N").End(xlUp).Row
'set up Criteria Area
Range("P1").Value = Range("F1").Value
For Each c In Range("N2:N" & r)
'add the rep name to the criteria area
ws1.Range("P2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Set ws2 = Sheets(c.Value)
Else
Set ws2 = Sheets.Add
End If
With ws2
.Move After:=Worksheets(Worksheets.Count)
.Name = c.Value
If .Range("A1").Value = "" Then
NextRow = 1
ElseIf .Range("A2").Value = "" Then
NextRow = 2
Else
NextRow = .Range("A1").End(xlDown).Row + 1
End If
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P12"), _
CopyToRange:=.Cells(NextRow, "A"), _
Unique:=False
End With
'start autofit all sheets
Cells.Select
Selection.ColumnWidth = 8.57
Cells.EntireColumn.autofit
Range("A1").Select
'end autofit all sheets
Next
ws1.Select
ws1.Columns("N").Delete
Application.ScreenUpdating = True
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Can this be done?
Thanks!
top. Now, the datas begin from row 1. I need this macro to work if the data
start from row 2, and row 1 is empty.
Macro:
Sub ExtractReps()
Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Dim NextRow
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database1")
'extract a list of Sales Reps
ws1.Columns("F:F").Copy _
Destination:=Range("P1")
ws1.Columns("P").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("N1"), Unique:=True
r = Cells(Rows.Count, "N").End(xlUp).Row
'set up Criteria Area
Range("P1").Value = Range("F1").Value
For Each c In Range("N2:N" & r)
'add the rep name to the criteria area
ws1.Range("P2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Set ws2 = Sheets(c.Value)
Else
Set ws2 = Sheets.Add
End If
With ws2
.Move After:=Worksheets(Worksheets.Count)
.Name = c.Value
If .Range("A1").Value = "" Then
NextRow = 1
ElseIf .Range("A2").Value = "" Then
NextRow = 2
Else
NextRow = .Range("A1").End(xlDown).Row + 1
End If
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("P12"), _
CopyToRange:=.Cells(NextRow, "A"), _
Unique:=False
End With
'start autofit all sheets
Cells.Select
Selection.ColumnWidth = 8.57
Cells.EntireColumn.autofit
Range("A1").Select
'end autofit all sheets
Next
ws1.Select
ws1.Columns("N").Delete
Application.ScreenUpdating = True
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Can this be done?
Thanks!