PDA

View Full Version : Solved: Well I Thought I Was Done???



coliervile
03-03-2008, 11:23 AM
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:

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

Best regards,

Charlie

Bob Phillips
03-03-2008, 12:33 PM
You should have studied the solution to the last problem, the solution to the first here is the same.



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


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



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


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
03-03-2008, 12:53 PM
:haha:

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
03-03-2008, 02:15 PM
"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
03-03-2008, 02:56 PM
Yes I made the changes.

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

coliervile
03-03-2008, 03:36 PM
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

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
03-03-2008, 03:36 PM
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

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

Bob Phillips
03-03-2008, 04:00 PM
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
03-03-2008, 04:42 PM
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
03-04-2008, 05:25 AM
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
03-04-2008, 10:46 AM
Any ideas of how to get past the error code listed in Thread #9?

coliervile
03-04-2008, 02:18 PM
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:

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

Bob Phillips
03-04-2008, 02:45 PM
I'll take look tomorrow Charlie.

coliervile
03-04-2008, 03:46 PM
Thanks "xld" have a good evening....:beerchug:

coliervile
03-04-2008, 05:12 PM
Here's the latest addition....

coliervile
03-05-2008, 06:44 AM
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??? :banghead:

Bob Phillips
03-05-2008, 07:22 AM
Try this



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

coliervile
03-05-2008, 10:20 AM
"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
03-05-2008, 10:21 AM
HERE'S THE WORKBOOK.....

Bob Phillips
03-05-2008, 10:39 AM
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?



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

coliervile
03-05-2008, 11:13 AM
when I get this bug resolved I'll spend the time fiddling with the BARF like color scheme...LOL

I'm still getting the the error message when the worksheet and listbox are empty. the error message is: Run-time error '13': Type mismatch at this location once again...

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

isn't this frustrating to you...it is to me!

Bob Phillips
03-05-2008, 11:53 AM
Frustrating? Blimey no! I love frying the brain cells solving someone else's problems so that they can go back to work the next day and show them all their latest masterpiece and get a big bonus ...

Anyway, I am sitting here, doing this, listening to George Jones, if I only had a glass of single malt I would be happy ...



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 Not IsArrayAllocated(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


Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = Not (IsError(LBound(Arr))) And _
IsArray(Arr) And _
(LBound(Arr) <= UBound(Arr))
End Function

johnske
03-05-2008, 03:39 PM
...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?
OMG! OMG! OMG! I just looked! It is horrible, too horrible to behold - my brain has been irrevocably corrupted and I will need extensive therapy and counselling to get over this trauma.

There should be some sorta rating or warning about viewing this displayed beforehand, you know like the PG, MA, etc ratings they have on movies, something like... TV, BI, MBI, VBI, EBI (traumatic viewing, barf inducing, mild barf inducing, violent barf inducing, extreme barf inducing) this seems to be around the VBI rating.

On second thoughts, maybe we should start a contest, with an appropriate award - the barfter award maybe? :devil2:

coliervile
03-05-2008, 04:57 PM
Hey "xld" that worked great....the way around it was totell it to ignore the error message and keep on truckin'??? Another fine product from those at VBA Express....:friends:

"xld"... sitting back and listening to some good tunes :djsmile: - what a life. I would buy you that single malt but I can't find a way for this computer to take my DEBIT CARD....so here you go :beerchug: . Does this work???

As far as getting bonuses- I work for the US Federal Goverment as an Air Traffic Controller and there aren't any bounuses or at least not for me. I give you all of the credit for this project and it's solution...my hat's off to you. :ole:

As far as the BARF Inducing trama that the color scheme has caused I'll post the final color scheme when I'm done and let you see the finished product. johnske sorry for any permanent damage that I may have caused you...he he he. :wot :rotflmao: .

Y'all have a great evening to all and THANKS AGAIN ""XLD" VBA WIZARD

Bob Phillips
03-06-2008, 02:07 AM
Hey "xld" that worked great....the way around it was totell it to ignore the error message and keep on truckin'??? Another fine product from those at VBA Express....:friends:

No, it is not ignoring the error. The code builds an array of all items and determines whether they match or not. I already had the code checking each element to see whether it matced or not and processed accordingly. When you originally pointed out the problem when the list was empty I added another check tat worked fine. Problem was that the check that worked fine when the list was empty barfed on non-empty list. Switching them barfed in reverse. So I added a more resilient array check (IsArrayAllocated) to see whether the array is empty or not, which handles empty and non-empty lists. I still have the test on individual elements of the array


"xld"... sitting back and listening to some good tunes :djsmile: - what a life. I would buy you that single malt but I can't find a way for this computer to take my DEBIT CARD....so here you go :beerchug: . Does this work???

The advantage of working from home. Actually I have a client who runs a small company, and they play music all day.

I don't need to be bought the malt, I have at least a dozen bottles in the house. Problem is I am off the booze, which is why if only ... AT least I am still allowed to listen to the music. Iris deMent today, and Bob Dylan's Theme Time Radio Hour.


As far as getting bonuses- I work for the US Federal Goverment as an Air Traffic Controller and there aren't any bounuses or at least not for me. I give you all of the credit for this project and it's solution...my hat's off to you. :ole:

Shame. I always get amazed that people think that the pay and bonuses of government workers should be screwed down, but no restraints on theirs. Hypocritical.

Is that a civilian ATC or military? Which airport?


As far as the BARF Inducing trama that the color scheme has caused I'll post the final color scheme when I'm done and let you see the finished product. johnske sorry for any permanent damage that I may have caused you...he he he. :wot :rotflmao: .

Look forward to seeing that. Colour and presentation is a big thing with me, I do presentations at conferences on visual aspects of Excel, dashboarding, and the like, so I will look with interest.

coliervile
03-06-2008, 08:41 AM
I've worked at both military installations, in my younger years, and I'm currently in the civilian side of Air Traffic Control with the Federal Aviation Administration. I've worked at 8 different airports now in the last 33 years.

Working with presentation and colors is there one scheme that's more palatable???
I should put this comment on my color scheme thread.