Hi to everyone,

I successfully run the below code taken from
http://www.contextures.com/excelfile...#Filter(FL0013 - Create New Sheets
from Filtered List) which I have copied in my workbook in separate module.

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").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("C1").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("Sheet1").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("Sheet1").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

But an error occurs on executing the macro if the following worksheet change
event codes in Sheet1 are present.

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh
Worksheets("Brief").PivotTables("BriefTable").Pivo tCache.Refresh
If Target.Column = 10 Then
Selection.AutoFilter field:=10, Criteria1:="="
End If
End Sub

How could I resolve the issue and successfully run the ExtractReps macro
even if worksheet change event is present in Sheet1.

Regards.

Hi Shabutt,

Your quote: "But an error occurs on executing the macro if the following
worksheet change event codes in Sheet1 are present."

What line does the error occur on and what is the error message?

One thing I notice is: Selection.AutoFilter field:=10, Criteria1:="="

What is selected when the code runs. Selection only refers to the active
sheet and selection must be on the worksheet to which the module with:
Private Sub Worksheet_Change(ByVal Target As Range).

Maybe a better way is to reference it as:
Sheets("Sheet1").AutoFilter.Range.AutoFilter field:=10, Criteria1:="="

--
Regards,

OssieMac


"shabutt" wrote:

Hi to everyone,

I successfully run the below code taken from
http://www.contextures.com/excelfile...#Filter(FL0013 - Create New Sheets
from Filtered List) which I have copied in my workbook in separate module.

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").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("C1").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("Sheet1").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("Sheet1").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

But an error occurs on executing the macro if the following worksheet change
event codes in Sheet1 are present.

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh
Worksheets("Brief").PivotTables("BriefTable").Pivo tCache.Refresh
If Target.Column = 10 Then
Selection.AutoFilter field:=10, Criteria1:="="
End If
End Sub

How could I resolve the issue and successfully run the ExtractReps macro
even if worksheet change event is present in Sheet1.

Regards.

Hi OssieMac,

The error occurs on the line:

Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh

The error is:

Run-time error '1004'"
Application-defined or object-defined error

I run the code on filter values (criteria) and worksheet change event is on
the intended sheet as well.

Regards.


"OssieMac" wrote:

Hi Shabutt,

Your quote: "But an error occurs on executing the macro if the following
worksheet change event codes in Sheet1 are present."

What line does the error occur on and what is the error message?

One thing I notice is: Selection.AutoFilter field:=10, Criteria1:="="

What is selected when the code runs. Selection only refers to the active
sheet and selection must be on the worksheet to which the module with:
Private Sub Worksheet_Change(ByVal Target As Range).

Maybe a better way is to reference it as:
Sheets("Sheet1").AutoFilter.Range.AutoFilter field:=10, Criteria1:="="

--
Regards,

OssieMac


"shabutt" wrote:

Hi to everyone,

I successfully run the below code taken from
http://www.contextures.com/excelfile...#Filter(FL0013 - Create New Sheets
from Filtered List) which I have copied in my workbook in separate module.

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").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("C1").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("Sheet1").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("Sheet1").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

But an error occurs on executing the macro if the following worksheet change
event codes in Sheet1 are present.

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh
Worksheets("Brief").PivotTables("BriefTable").Pivo tCache.Refresh
If Target.Column = 10 Then
Selection.AutoFilter field:=10, Criteria1:="="
End If
End Sub

How could I resolve the issue and successfully run the ExtractReps macro
even if worksheet change event is present in Sheet1.

Regards.

Hi Shabutt,

I am only guessing with this but I am thinking that the event is being
triggered by a change created when another worksheet is activated. You could
try the following:-

Worksheets("Summary").Select
Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh

If that doesn't work then I am fresh out of ideas.

--
Regards,

OssieMac

Hi OssieMac,

Thank you again. I have found the problem. The pivottables are based on
database range on sheet1 and the pivottables are refreshed when there is
change in sheet1. When I run the 'ExtractReps', the error occurred due to
mismatch in the ranges because the database range is upto G column and the
'ExtractReps' creates two columns L & J (L for list of Sales Reps and J for
unique items from L column).

See below line from 'ExtractReps':

'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

The problem resolved once I changed column L to H and column J to I in the
entire code of 'ExtractReps'. So now there are no empty data columns between
database range and temporary created columns H & I.

Regards.

"OssieMac" wrote:

Hi Shabutt,

I am only guessing with this but I am thinking that the event is being
triggered by a change created when another worksheet is activated. You could
try the following:-

Worksheets("Summary").Select
Worksheets("Summary").PivotTables("SummaryTable"). PivotCache.Refresh

If that doesn't work then I am fresh out of ideas.

--
Regards,

OssieMac