PDA

View Full Version : 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.

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

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.


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

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.

:banghead: :dunno

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.

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

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?:huh:

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
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

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.... :help 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.

:friends:

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



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


Userform2



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


Userform4



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


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

coliervile
03-09-2008, 03:52 PM
Thanks "XLD" I made the changes and I'm just to tired to fool with any more today...thanks for your help.

coliervile
03-10-2008, 06:15 AM
Okay I think I've finished this project, thank you "XLD". Do to my inexperience I ran into problems when I copied the original userform and tried to make a new userform. I went back and from scratch remade the employee userform to request time off from work, activated by Employee Leave Request Form button, on the "Dashboard". Please take a look at the overall workbook and please let me know what you think. I would like to thank all of you that helped me with this, especially "XLD" the "GURU of VBA". Look forward to your comments and any suggestions and if you find any bugs please let me know.

coliervile
03-10-2008, 06:58 AM
I found a glitch and can't figure out why it's happening. I opened the Administrative Form (on the Dashboard) and then clicked on to the Edit Selection and opened the Userform4 and edited the Name- "CC"- Start- date to Mar-13-2008 and when I hit the Submit Changes button the Start date unloaded on to the Leave Request worksheet as mmm-dd-yyyy and not as Mar-13-2008? Any ideas why?

coliervile
03-10-2008, 08:56 AM
It would seem to me there's a format problem issue between the Edit Form userform and the frmRequest- ListBox1. I've tried various formats and can't seem to get it to make the proper edits. Any ideas????

coliervile
03-10-2008, 08:35 PM
Does anyone have any ideas about the above problem??? I think the problem is formatting from the Edit Form when it downloads the edited information back on to the ListBox! on the frmRequest. I've tried several different things and all of them failed. Any ideas would be appreciated

coliervile
03-11-2008, 06:19 AM
Any Ideas on how to resolve this problem would be greatly appreciated.

:beg: :115: :Thinkingo