Solved: Well I Thought I Was Done???

[coliervile]

First and foremost a tremendous thanks to "xld" for assisting and patience with me and working on this project. I think there's two remaining issues with this project:

1) When the userform "frmRequest" unloads into the worksheet "Leave Request" and into each new row column "B" is formatted as .Cells(strLastRow + 1, 2).Value = Format(Now, "dd mmm yyyy hh:mm:ss"). The problem is if that is the only row in the "Leave Request" listbox1 and is deleted vis the "Delete Selection" button everything is deleted except for the data that's in column "B" "3/3/2008 1:09:35 PM". Is there a way to delete all of the information from the "Leave Request" worksheet including the formatted column "B" data???

2) If the user tries the date search on the userform "Quick Serach By Date" button and there's no data in the "Leave Request" worksheet an error message come up: "Type mismatch" at this location of the coding: For i = LBound(mpRows) To UBound(mpRows) What I want to happen is for the message box (it's already in the coded in BLUE) to come up. The coding works correctly for the "Quick Search By Name" and the message box displays as it should, but can't figure out how to fix the other. Here's the coding for this:

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "yyyy-mm-dd") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "yyyy-mm-dd") & """)," & _
"ROW(" & mpNames.Address & "))")

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If

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

Sheets("Leave Request").Visible = False
End With
End Sub[/VBA]

Best regards,

Charlie

[Bob Phillips]

You should have studied the solution to the last problem, the solution to the first here is the same.

[vba]

Private Sub cmdDel_Click()
Dim mpLastRow As Long

Application.EnableEvents = False

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

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

Range(.RowSource)(.ListIndex + 1, 1).EntireRow.Delete
'Update listbox
.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
[/vba]

On the second one, we need to check whether the array built is empty or not

[vba]

Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "yyyy-mm-dd") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "yyyy-mm-dd") & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If
End If

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

Sheets("Leave Request").Visible = False
End With
End Sub
[/vba]

BTW, I have to ask this as I have seen it so many times. Do you actually like that colour scheme? From my perspective, I would say it ooks vomit inducing.

[Simon Lloyd]

BTW, I have to ask this as I have seen it so many times. Do you actually like that colour scheme? From my perspective, I would say it looks vomit inducing.

It does look .....to be kind....un-inviting!

[coliervile]

"xld" I'm at work and haven't got a chance to read through the coding, but I will and get back with you. Did you actually make changes to the "old coding"?

The coloring is ugly...it's to detour employees from taking time-off of work...LOL. I'm just playing with it and the palette will improve.

Best regards,

Charlie

[Bob Phillips]

Yes I made the changes.

I would think it is mor likely to drive them off sick!

[coliervile]

Thanks "xld" the Delete selection worked great. The Quick Search By Date is still running into the same error at the same location in "RED". Now this only happens when there's no data in the listbox/worksheet "Leave Request".

Best regards,

Charlie

[VBA]Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "yyyy-mm-dd") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "yyyy-mm-dd") & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If
End If

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

End With
End Sub[/VBA]

[coliervile]

Thanks "xld" the Delete selection worked great. The Quick Search By Date is still running into the same error at the same location in "RED". Now this only happens when there's no data in the listbox/worksheet "Leave Request".

Best regards,

Charlie

[VBA]Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "yyyy-mm-dd") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "yyyy-mm-dd") & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If
End If

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

End With
End Sub[/VBA]

[Bob Phillips]

Can you say that in another way, I am not sure that I understand.

I tested it, and it worked fine with no records, one record.

[coliervile]

Okay...there's nothing on the "Leave Request" worksheet and the listbox on the userform "frmRequest" is empty...now when I use the "Quick Search by Date" button on the userform "frmRequest" and the Search Date userform opens and I enter a date of 12-Mar-2008 and hit the enter button I get the following error: Run-time error '13': Type mismatch. When I click on Debug it goes to the line in the coding that I've colored RED (and is highlighted in YELLOW in the actual coding) as if there's something wrong in this line??? I copied your coding for ""Private Sub TextBox1_AfterUpdate()"" twice to make sure I didn't get something goofed up.

Best regards,

Charlie

Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "yyyy-mm-dd") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "yyyy-mm-dd") & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If
End If

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

End With
End Sub

[coliervile]

Good morning to all. "xld" when I mouse over the highlighted coding error (mettioned in my previous thread #9) I get this:

LBound(mpRows) = <Type mismatch> moused over LBound(mpRows)

UBound(mpRows) = <Type mismatch> moused over UBound(mpRows)

For i = LBound(mpRows) To UBound(mpRows) (this is the code error)

If you tested your coding and it works can you attach the workbook and see if yours run on my computer???

Best regards,

Charlie

[coliervile]

Any ideas of how to get past the error code listed in Thread #9?

[coliervile]

Well I got the search date to work, but after I close the message boxes I still get the ERROR MESSAGE of Run-time error '13': Type mismatch at the same exact location. Any resason for this happening???? Here's what i added into the coding colored in BLUE: The RED is the error location:

[VBA]Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=--""" & Format(mpTestDate, "dd-mmm-yyyy") & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
Format(mpTestDate, "dd-mmm-yyyy") & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then
MsgBox mpMessage, vbOKOnly + vbInformation
Else
MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If

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

Sheets("Leave Request").Visible = False
End With
End Sub[/VBA]

[Bob Phillips]

I'll take look tomorrow Charlie.

[coliervile]

Thanks "xld" have a good evening....

[coliervile]

Here's the latest addition....

[coliervile]

I came across this article on a possible problem of how the dates are formatted http://support.microsoft.com/kb/211601 . The article refersto XL2000 and I run XL2003 shouldn't make a difference. I went through and changed all of the date formats to mmm-dd-yyyy and I'm still coming up with the same error: Run-time error '13': Type mismatch but this code comes up as Error 2015 at this location in the coding: If mpRows(i, 1) <> False Then . The message box is coming up with no matches even though the date searched for is in the listbox and the worksheet "Leave Request". What am I missing here???

[Bob Phillips]

Try this

[vba]

Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=""" & CLng(mpTestDate) & """)*" & _
"(" & mpDatesEnd.Address & ">=--""" & _
CLng(mpTestDate) & """)," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
End If
End If

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

Sheets("Leave Request").Visible = False
End With
End Sub


[/vba]

[coliervile]

"xld" this one isn't working either. It doesn't put a message box up when there's no data in the listbox on the user form. It's also pulling up information, by date requested, when there's not any dates requested....i.e. date search March 19, 2008: there are two requests in for March, but there none requested for March 19,2008, but it's displaying employee "BB" as requesting March 19, 2008 and employee "BB" requested off March 23, 2008 until March 27, 2008???

[coliervile]

HERE'S THE WORKBOOK.....

[Bob Phillips]

I've found the problem!

Those sick-inducing colours that you are using are frying my brain cells. I have just calculated that I have lost 10,328,763,489 since I first encountered this monster, and it is accelearting as you make it even ghastlier. Do you realise what harm you are doing to the Excel community?

[vba]

Private Sub TextBox1_AfterUpdate()
Dim mpLastRow As Long
Dim mpRows As Variant
Dim mpNames As Range
Dim mpDatesStart As Range
Dim mpDatesEnd As Range
Dim mpTestDate As Date
Dim mpMessage As String
Dim LastRowPrintout As Long
Dim i As Long

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

mpTestDate = CDate(Me.TextBox1.Text)
mpLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set mpDatesStart = .Range("D1").Resize(mpLastRow)
Set mpDatesEnd = .Range("E1").Resize(mpLastRow)
Set mpNames = .Range("A1").Resize(mpLastRow)

mpRows = .Evaluate("IF((" & mpDatesStart.Address & _
"<=" & CLng(mpTestDate) & ")*" & _
"(" & mpDatesEnd.Address & ">=" & _
CLng(mpTestDate) & ")," & _
"ROW(" & mpNames.Address & "))")

If IsEmpty(mpRows) Then

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
Else

For i = LBound(mpRows) To UBound(mpRows)

If mpRows(i, 1) <> False Then

mpMessage = mpMessage & "Requested" & " " & mpTestDate & " " & _
"Off- " & " " & mpNames.Cells(i, 1).Value & _
" (Leave type: " & mpNames.Cells(i, 3).Value & _
", Requested on: " & mpNames.Cells(i, 2).Text & ")" & vbNewLine & vbNewLine

LastRowPrintout = Worksheets("Printout").Range("A" & Rows.Count).End(xlUp).Row
.Rows(i).Copy Worksheets("Printout").Range("A" & LastRowPrintout + 1)
End If
Next i

If mpMessage <> "" Then

MsgBox mpMessage, vbOKOnly + vbInformation
Else

MsgBox "No Leave Request For This Date", vbOKOnly + vbInformation
End If
End If

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

Sheets("Leave Request").Visible = False
End With
End Sub
[/vba]