Type mismatch problem in array - ??

[ina]

Hello,

I have a problem with a type mismatch on this sub. and really I do not
know where could someone check it or gives me some suggestions

I thank you

Ina

Public Function GetPriceRoom(ByVal strCode As String) As Variant
On Error GoTo GetPriceRoom_Err

' ************
' Variables
' ************'
Dim dtmBeginMonth As Date
Dim dtmEndMonth As Date
Dim dtmStart As Date
Dim dtmCurrent As Date
Dim dtmToday As Date
Dim i As Integer
Dim r As Integer
Dim j As Integer
Dim varPrice As Variant
Dim vartbl(1 To 1000, 1 To 9) A
Dim strFormula As String
Dim StrFormula2 As String
Dim strtblSource(1 To 4) As String
Dim strCode as String

' ************
' array with the name of different sources
' ************
strtblSource(1) = "INTERNET"
strtblSource(2) = "ADMIN"
strtblSource(3) = "FAX"
strtblSource(4) = "PHONE"

dtmToday = Date

strFormula = "getdate(""ROOMPRICE"", """ & strCode & """, ""ROOM"")"
dtmStart = Evaluate(strFormula)

' ************
' set the start date (dtmStart) to the end of the month and set up as
the dtmCurrent
' ************

dtmEndMonth = getendofmonth(dtmStart) ' a function
dtmCurrent = dtmEndMonth

' ************
' counter
' ************
i = 0
r = 1


Debug.Print dtmCurrent; dtmEndMonth


' ************
' while the different between the dtmCurent and dtmToday is greater
than 0; it executes this code bellow
' ************
While DateDiff("m", dtmCurrent, dtmToday) > 0


' ************
' It sets the dtmCurrent as begin of month
' ************
dtmBeginMonth = getbeginofmonth(dtmCurrent)

' ************
' Price = N/A # in order to get in to the loop (while)
' ************
varPrice = CVErr(xlErrNA)

While IsError(varPrice)

' ************
' to calculate the Price Source; It sees if it fits; if yes, it
is the case It gets out of for loop
' insert source in this formula
' ************
For j = 1 To 4 '

StrFormula2 = "GetPrice(""RoomPRICE"",""" & strCode & """,
""ROOM"", """ & dtmCurrent & """, """ & strtblSource(j) & """)"
varPrice = Evaluate(StrFormula2)


If Not IsError(varPrice) Then 'Maybe error here
Exit For
End If

Next j

' ************
' if there is not varPrice for this date you need to do date -
1 day and reloop it again!
' ************
dtmCurrent = dtmCurrent - 1

Wend

' ************
' if the varPrice different from N/A#; it needs to - 1 day to
the date as the the code has been execute a extra time
' ************
dtmCurrent = dtmCurrent + 1



' ************
' now you need to check if the different between the dtmCurrent and
beginofmonth of this dtmCurrent is less then 0
' if it is the case the price will have no value ""
' ************
If DateDiff("d", dtmBeginMonth, dtmCurrent) < 0 Then

varPrice = ""
dtmCurrent = dtmBeginMonth

End If

vartbl(r, 1) = strCode
vartbl(r, 2) = dtmCurrent
vartbl(r, 3) = varPrice
vartbl(r, 4) = strtblSource(j)
vartbl(r, 5) = "Room"
vartbl(r, 6) = "COMMENTS"


r = r + 1

' ************
'It will go on for the next month
' *************
dtmCurrent = getnextendofmonth(dtmCurrent)


Wend

Dim rngNextCell As Range
Set rngNextCell = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

' ************
'Resize the range to set the vartbl
' *************

rngNextCell.Resize(UBound(vartbl, 1) - LBound(vartbl, 1) + 1,
UBound(vartbl, 2) - LBound(vartbl, 2) + 1).Value = vartbl

' ************
' Format data
' *************
Columns(2).NumberFormat = "yyyy/mm/dd"


' ************
' delete row containing cell with no values
' *************
Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

' ************
' call the function
' *************
GetPriceRoom = vartbl


GetPriceRoom_Err:
MsgBox Err.Description, vbExclamation, "GetPriceRoom" & Err.Number

End Function

 

[Ardus Petus]

Temporarily suppress the On Error goto GetPriceRoom_Err
VBE will underline (yellow) the offending instruction

HTH

 

[ina]

I did but why I have this error

 

[Ardus Petus]

On which line does the error happen?

 

[ina]

exactly I do not know because I have something like in a msgbox
GetPriceRoom0 and GetPriceRoom13

 

[Ardus Petus]

You have to "protect" your error handler from being executed sequentially
when you hit the end of "normal" code

Add a line
Exit Function
just before your tag: GetPriceRoom_Err:

HTH

 

[ina]

Thanks I will do it.

Ina