Solved: Advanced Filter Error

**coliervile** · 03-09-2008, 03:37 AM

When the following macro is fired it is suppose to make new worksheets with the employee names from worksheet "Leave Request", column "A" and copy all associated rows from the "Leave Request" worksheet to a new worksheet. I'm getting an error: Run--time error '1004': Method 'Range' of object'_Global' failed. The area in red is what is highlighted when the debug window displays.

[VBA]Sub ExtractEmp()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Leave Request")
Set rng = Range("Database")
'extract a list of employees'
ws1.Columns("A:A").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 employee to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet and run advanced filter
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
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub[/VBA]

**coliervile** · 03-09-2008, 03:53 AM

Found part of the problem....Define_Name_Database didn't take for some reason, but is now defined (Database =Leave Request!$A$1:$E$1000). I'm still getting the same error message though???

**coliervile** · 03-09-2008, 04:40 AM

I had to change the coding so that when the information was updated and a sheet already exists for a employee, it will be cleared, and the data will be extracted to that sheet without causing yet another error, but I'm still getting an error in the code and at the same location: Run--time error '1004': Could not find specified object. When I run the debug_step over it comes up with: Run--time error '1004': Method 'Range' of object'_Global' failed.Both errors occur at this location: Set rng = Range("Database").

**p45cal** · 03-09-2008, 08:33 AM

It might be an idea to remove passwords

**coliervile** · 03-09-2008, 09:19 AM

Sorry about that, the password is "password". I found the problems"

1) when defining "Database" in the Define Name I failed to put single quotation marks either side of the worksheet (='Leave Request'!$A$1:$E$1000)

2) I was also running the code from a command button on the "Dashboard" worksheet a no, no according to a article I read on VBAexpress "Advanced Filters" May 9, 2005 (thank you "XLD"). The article stated

The big problem with Advanced Filter is that it needs to filter to the same sheet, it is the activesheet

3) So in order to run the coding from another worksheet and command button I had to add the following to select the worksheet and cell to make the worksheet active:

Sheets("Leave Request").Visible = True
Sheets("Leave Request").Select
Range("F1").Select

and this to get back out of the worksheet:

Sheets("Leave Request").Visible = False

This took care of the problem and it runs fine. Hope this helped out others as well.

[VBA]Sub ExtractEmp()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Leave Request")
Set rng = Range("Database")

Sheets("Leave Request").Visible = True
Sheets("Leave Request").Select
Range("F1").Select

'extract a list of employees
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 employee 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("Leave Request").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("Leave Request").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete

Sheets("Leave Request").Visible = False

End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function[/VBA]

**coliervile** · 03-09-2008, 09:29 AM

What

**coliervile** · 03-09-2008, 09:33 AM

What I would like to do now is add to the coding above and copy the formatting of the columns from "Leave Request" columns "A:E" to the new perspective worksheets.

**Bob Phillips** · 03-09-2008, 10:14 AM

This is moving on isn't it?

What steps do you have to follow to be able to test this route, creating these new worksheets?

**coliervile** · 03-09-2008, 10:22 AM

"XLD" how are you to day? Yes this project is moving long. I'm enjoying learning about this...VBA's. Sorry "XLD" I'm not understanding you question about testing.

I want to just copy the formating of the "Leave Request" worksheet and not just the columns so that all of the sheets are formatted the same.

**mikerickson** · 03-09-2008, 10:25 AM

Advanced Filter will work with dataRange, criteriaRange and CopyToRange all in different sheets or workbooks. From the keyboard, the criteriaRange sheet should be active when entering the specifics into the dialog box. But from VB, using fully qualifying Ranges gives me no problems.

**Bob Phillips** · 03-09-2008, 10:29 AM

Sure I understand, but I just what to know how to create the situation so that I can see what happens and look at the code to see what to change. I am not sure as to what buttons I need to press.

**coliervile** · 03-09-2008, 11:00 AM

Thanks for your help and here's a copy of the workbook and coding.

[vba]Sub ExtractEmp()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Leave Request")
Set rng = Range("Database")
Sheets("Leave Request").Visible = True
Sheets("Leave Request").Select
Range("F1").Select
With Worksheets("Leave Request")
.Range("A:E").Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlYes
'extract a list of employees
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 employee 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("Leave Request").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("Leave Request").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
.Range("A:E").Sort Key1:=.Range("D2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
End With
Sheets("Leave Request").Visible = False
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function[/vba]

**Norie** · 03-09-2008, 11:10 AM

Charlie

Why post a workbook with the code password protected?

How can anyone see the code to try and find out the problem?

**coliervile** · 03-09-2008, 11:12 AM

I had posted the password in a earlier thread...it's "password". Sorry about that.

**Norie** · 03-09-2008, 11:27 AM

Charlie

I don't have time to look into this particular problem - in fact you've not as XLD asked told us how we can recreate it.

Remember this is your data and your code.

But anyways a couple of general points.

1 There seems to be a lot of flickering between sheets. That either indicates you are using Select/Activate which isn't normally needed. Or that you aren't using Application.DisplayUpdate = False which is normally recommended.

2 Why do you appear to have a seperate sheet for each person? Wouldn't it be easier to manage if you had one sheet with the data for everybody on it.

**Bob Phillips** · 03-09-2008, 11:31 AM

[vba]

Sub ExtractEmp()
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range

Set rng = Range("Database")

With Worksheets("Leave Request")

.Range("A:E").Sort Key1:=.Range("A2"), _
Order1:=xlAscending, _
Header:=xlYes

'extract a list of employees
.Columns("A:A").Copy Destination:=.Range("L1")
.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 employee name to the criteria area
.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then

Set wsNew = Sheets(c.Value)
wsNew.Cells.Clear
Else

Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
End If

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
.Cells.Copy
wsNew.Cells.PasteSpecial Paste:=xlPasteFormats
Next

.Columns("J:L").Delete

.Range("A:E").Sort Key1:=.Range("D2"), _
Order1:=xlAscending, _
Key2:=.Range("B2"), _
Order2:=xlAscending, _
Header:=xlYes
End With

End Sub
[/vba]

**coliervile** · 03-09-2008, 12:13 PM

Thanks "XLD" that did the trick. I've run into a glitch on something else now. The Edit Selection and Delete Selection aren't working correctly. I went back to earlier version and it started happening when I made the Administrative part of the workbook. The Edit Selection s loading the date or at least one of them as mmm-dd-yyyy instead of Mar-9-2008. The Delete Selection isn't deleting the correct selection. IT"S FRUSTRATING!

I though I just about had this thing done....

please.

**coliervile** · 03-09-2008, 12:15 PM

Here's the workbook and the passwords are "password"

**coliervile** · 03-09-2008, 01:25 PM

Okay I've got my problem resolved for now, thanks folks for your help.

**Bob Phillips** · 03-09-2008, 02:28 PM

I think you have 3 main problems, you are referring to frmRequest rather than the new frmRequest2, the Worksheet change routine was wrong, and you are not fully qualifying objects.

Leave Request worksheet

[vba]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
For Each Cell In Target
With Cell
If .Column = Range("A:A").Column Then
Me.Cells(.Row, "B").Value = Format(Now, "mmm-dd-yyyy hh:mm:ss")
Me.Cells(.Row, "D").Value = Format(Me.Cells(.Row, "D").Value, "mmm-dd-yyyy")
Me.Cells(.Row, "E").Value = Format(Me.Cells(.Row, "E").Value, "mmm-dd-yyyy")
End If
End With
Next Cell

If Not Intersect(Target, Me.Range("B:B", "E:E")) Is Nothing Then

Me.Columns("A:E").Sort Key1:=Me.Range("D2"), Order1:=xlAscending, _
Key2:=Me.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
End If
End Sub
[/vba]

Userform2

[vba]

Private Sub CommandButton1_Click()
Dim mpLastRow As Long
Dim ws1 As Worksheet

Application.EnableEvents = False

Set ws1 = Worksheets("Leave Request")

With frmRequest2.ListBox1

'Check for selected item
If (.Value <> vbNullString) Then

'If more then one data rows
If .ListIndex >= 0 Then

ws1.Range(.RowSource)(.ListIndex + 1, 1).EntireRow.Delete
'Update listbox
mpLastRow = xlLastRow("Leave Request")
.RowSource = "'Leave Request'!A2:E" & mpLastRow
Else

MsgBox "Please Select Data"
End If
End If
End With

Application.EnableEvents = True

With Worksheets("Leave Request")
.Range("A:E").Sort Key1:=.Range("D2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
End With
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub
[/vba]

Userform4

[vba]

Private Sub CommandButton1_Click()
Dim ws1 As Worksheet

Set ws1 = Worksheets("Leave Request")

Application.ScreenUpdating = False
With frmRequest2.ListBox1
'Check for selected item
If (.Value <> vbNullString) Then

ws1.Range(.RowSource)(.ListIndex + 1, 1).Value = UserForm4.TextBox1.Value
ws1.Range(.RowSource)(.ListIndex + 1, 2).Value = UserForm4.TextBox2.Value
ws1.Range(.RowSource)(.ListIndex + 1, 3).Value = UserForm4.TextBox3.Value
ws1.Range(.RowSource)(.ListIndex + 1, 4).Value = CDate(UserForm4.TextBox4.Value)
ws1.Range(.RowSource)(.ListIndex + 1, 5).Value = CDate(UserForm4.TextBox5.Value)

Else
MsgBox "Please Enter Data"

End If
End With

Unload Me
With Worksheets("Leave Request")

.Range("A:E").Sort Key1:=.Range("D2"), Order1:=xlAscending, _
Key2:=.Range("B2"), Order2:=xlAscending, _
Header:=xlYes
End With
Sheets("Dashboard").Select
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Unload Me
Sheets("Dashboard").Select
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
Dim ws1 As Worksheet

Set ws1 = Worksheets("Leave Request")

With frmRequest2.ListBox1
'Check for selected item
If (.Value <> vbNullString) Then

'If more then one data rows
If (.ListIndex >= 0 And xlLastRow("Leave Request") > 1) Then

UserForm4.TextBox1.Value = ws1.Range(.RowSource)(.ListIndex + 1, 1).Value
UserForm4.TextBox2.Value = ws1.Range(.RowSource)(.ListIndex + 1, 2).Value
UserForm4.TextBox3.Value = ws1.Range(.RowSource)(.ListIndex + 1, 3).Value
UserForm4.TextBox4.Value = ws1.Range(.RowSource)(.ListIndex + 1, 4).Value
UserForm4.TextBox5.Value = ws1.Range(.RowSource)(.ListIndex + 1, 5).Value
End If
End If
End With
End Sub
[/vba]

As an aside, you should name all of your controls, not leave it to the system defaults. Just good programming practice.

Thread: Solved: Advanced Filter Error

Thread Tools

Display

Solved: Advanced Filter Error

Posting Permissions