I'm trying the following code, but when the second error happened it does not handle it but stops and gives a Type mismatch error
The idea is that when the cell does contain values that aren't Date should leave the value and (ideally should show an error message, but I was not able to insert it) and go next
Set iDateRowSupportRange = Range(iDateStarCell, iDateEndCell)
For iDateColNr = 1 To iDateRowSupportRange.Columns.Count
iDateValue = Cells(Range(iDateStarCell).Row, iDateColNr).Value
If UCase(iDateValue) = "DATE" Then
Set iDateRange = Range(Range(DbFirstCell).Offset(0, iDateColNr - 1).Address, Cells(DbLastRowNr, iDateColNr).Address)
iDateArray = iDateRange
For iDateArrayRow = 1 To UBound(iDateArray, 1)
If iDateArray(iDateArrayRow, 1) <> "" Then
On Error GoTo ErrorFlow
If Len(Day(iDateArray(iDateArrayRow, 1))) = 2 Then
dd = Day(iDateArray(iDateArrayRow, 1))
Else
dd = "0" & Day(iDateArray(iDateArrayRow, 1))
End If
If Len(Month(iDateArray(iDateArrayRow, 1))) = 2 Then
mm = Month(iDateArray(iDateArrayRow, 1))
Else
mm = "0" & Month(iDateArray(iDateArrayRow, 1))
End If
yyyy = Year(iDateArray(iDateArrayRow, 1))
iDateArray(iDateArrayRow, 1) = dd & "." & mm & "." & yyyy
ErrorFlow:
iDateArray(iDateArrayRow, 1) = iDateArray(iDateArrayRow, 1)
End If
Next iDateArrayRow
iDateRange = iDateArray
End If
Next
Any idea where I do it wrong, and how can I handle this?
Related
All I am trying to pull data from a web page.
I am looping through div with a class name from the webpage. Sometimes specific elements inside the div does not exist. that time it's showing an error
runtime error 91 object variable or with block variable not set
my VBA code is as below
m = 0
For Each htmlele1 In doc.getElementsByClassName("results")
m = m + 1
companyname = htmlele1.getElementsByTagName("h2")
Address = htmlele1.getElementsByTagName("span")
If Address.getAttribute("itemprop") = "Address" Then
Cells(i, (m * 4 + 2)).Value = companyname.innerText + "," + Address.innerText
End If
Teliphone = htmlele1.getElementsByClassName("nolink")
If Teliphone.getAttribute("itemprop") = "telephone" Then
Cells(i, (m * 4 + 3)).Value = Teliphone.innerText
End If
no_of_property = htmlele1.getElementsByClassName("agents-stats-l")
If InStr(no_of_property.innerText, "Residential for sale") <> 0 Then
Cells(i, (m * 4 + 4)).Value = Replace(no_of_property.innerText, "Residential for sale:", "")
Else
Cells(i, (m * 4 + 4)).Value = 0
End If
Sale_price = htmlele1.getElementsByClassName("agents-stats-c")
If InStr(Sale_price.innerText, "Avg. asking price") <> 0 Then
Cells(i, (m * 4 + 5)).Value = Replace(Sale_price.innerText, "Avg. asking price: ", "")
Else
Cells(i, (m * 4 + 5)).Value = 0
End If
Next
on above code snippet sometimes
** Teliphone = htmlele1.getElementsByClassName("nolink")** This is with snolink class and this doesnot exists some time and it shows error on next line.
How can I check whether element with class exists and overcome "runtime error 91 object variable or with block variable not set" this error
You need to set the object beforehand and check if exists before attempting to access its properties.
Set objCollection = htmlele1.getElementsByClassName("nolink")
If Not objCollection Is Nothing Then
For Each objTeliphone In objCollection
'Access objTeliphone properties here
Next
End If
So, I'm having some problems with dates that are reversing themselves in VBA when assigned to a Date variable. It's simpler than it sounds, but it's really bugging me.
Code:
Dim InsertedDate as Date
On Error Resume Next
InsertedDate = Me.BoxDate.Value
If InsertedDate = 0 Then
'Do Something
Else
'Do Something Different
End If
So let's assume that user types a value like
12/18/2017
I'm brazilian, so that means the user typed the 12th day of the 18th month. Since there's no 18th month in the year, the user shouldn't be able to type that date and InsertedDate should be equal to 0, right? Or not? I mean, I'm not really sure how Excel work dates.
Anyway, what happens is: Excel automatically reverses the date to
18/12/2017 'InsertedDate Value
instead of InsertedDate being
12/18/2017 'InsertedDate Value
And the code goes to 'Do Something Different. So, how do I solve this? Notice that I haven't assigned the variable value to anything. The process of reversion happens automatically when assigning the value to the variable. I've already tried
Format(InsertedDate, "dd/mm/yyyy") 'Did not work
and
InsertedDate = CDate(Me.BoxDate.Value) 'Did not work
and I tried converting the values in other variables and stuff. So, I'm lost. If anyone could help me, I'd be extremely grateful. Thank you in advance.
If you choose data type as Date it will automatically convert dates to american format.
My suggestion is to check the date format of the user and assume he uses the same (and it is not the safest assumption):
If Application.International(xlMDY) then
InsertedDate = Me.BoxDate.Value
Else:
Arr = Split(Me.BoxDate.Value,"/")
InsertedDate = DateSerial(Arr(2),Arr(1),Arr(0))
End if
But it assumes that user has used "/" as a delimite - and there could be a lot of other scenarios. You can use a date picker instead or a function that will validate the date.
EDIT:
Actually here is a variation of function I use and its implementation in your code:
Sub TestDate()
If ConformDate(Me.BoxDate.Value) = "" Then
MsgBox "Invalid Date!"
Else
MsgBox "" & ConformDate(Me.BoxDate.Value) & " is a valid date"
End If
End Sub
Function ConformDate(DataToTransform As String) As String
Dim DTT As String
Dim delim As String
Dim i As Integer
DTT = DataToTransform
DTT = Trim(DTT)
With CreateObject("VBScript.RegExp")
.Pattern = "\s+"
.Global = True
DTT = .Replace(DTT, " ")
End With
Select Case True
Case (DTT Like "*/*/*")
delim = "/"
Case (DTT Like "*-*-*")
delim = "-"
Case (DTT Like "*.*.*")
delim = "."
Case (DTT Like "* * *")
delim = " "
Case Else
ConformDate = ""
Exit Function
End Select
Arr = Split(DTT, delim)
If UBound(Arr) < 2 Then
ConformDate = ""
Exit Function
End If
Dim Arrm(2) As String
If Application.International(xlMDY) Then
Arrm(0) = Arr(0)
Arrm(1) = Arr(1)
Arrm(2) = Arr(2)
Else
Arrm(0) = Arr(1)
Arrm(1) = Arr(0)
Arrm(2) = Arr(2)
End If
For i = LBound(Arrm) To UBound(Arrm)
If Not IsNumeric(Arrm(i)) Then
ConformDate = ""
Exit Function
End If
Select Case i
Case 0
' Month
If Len(Arrm(i)) < 1 Or Len(Arrm(i)) > 2 Then
ConformDate = ""
Exit Function
End If
If Left(Arrm(i), 1) = "0" And Len(Arrm(i)) = 1 Then
ConformDate = ""
Exit Function
End If
If Left(Arrm(i), 1) = "0" Then Arr(i) = Right(Arrm(i), 1)
If Arrm(i) > 12 Then
ConformDate = ""
Exit Function
End If
Case 1
' Day
If Len(Arrm(i)) < 1 Or Len(Arrm(i)) > 2 Then
ConformDate = ""
Exit Function
End If
If Left(Arrm(i), 1) = "0" And Len(Arrm(i)) = 1 Then
ConformDate = ""
Exit Function
End If
If Left(Arrm(i), 1) = "0" Then Arrm(i) = Right(Arrm(i), 1)
If Arrm(i) > 31 Then
ConformDate = ""
Exit Function
End If
Case 2
' Year
If Not (Len(Arrm(i)) = 2 Or Len(Arrm(i)) = 4) Then
ConformDate = ""
Exit Function
End If
If Len(Arrm(i)) = 2 Then Arrm(i) = Left(Year(Date), 2) & CStr(Arrm(i))
End Select
Next
If Application.International(xlMDY) Then
ConformDate = Format((DateSerial(CInt(Arrm(2)), CInt(Arrm(0)), CInt(Arrm(1)))), "dd/mm/yyyy")
Else
ConformDate = Format((DateSerial(CInt(Arrm(2)), CInt(Arrm(1)), CInt(Arrm(0)))), "dd/mm/yyyy")
End If
End Function
I just could think of a way to make it on the hardest way, which is extracting each element and comparing.
diamesano = Me.BoxDate.Value
'diamesano = "12/18/2017"
dia = CLng(Left(diamesano, 2))
mes = CLng(Left(Mid(diamesano, 4), 2))
ano = CLng(Right(diamesano, 4)) 'Assuming year with 4 digits, otherwise some tweaks are necessary
Debug.Print "day: " & dia & " month: " & mes & " Year: " & ano
date_error = 0
If mes >= 1 And mes <= 12 Then 'Check if month is ok
mesAno = (Right(diamesano, 7))
DiasNoMes = Day(DateSerial(Year(mesAno), Month(mesAno) + 1, 0))
If dia >= 1 And dia <= DiasNoMes Then 'Check the amount of days on this month and if is in range
Debug.Print "OK"
'Do something because the Date is valid!
Else
date_error = 1
End If
Else
date_error = 1
End If
If date_error = 1 Then
Debug.Print "NOK"
'Date is invalid =P
End If
Tried to use IsDate() function, but it reversed the date, even if formatting "dd/mm/yyyy" is used before.
Edit:
UDF to split the date
If the user input another format as "d/m/yy", the code below will correct. In which the function EXTRACTELEMENT will split the String by / and get the elements.
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
MsgBox "ERROR: Verify if the data exists, example if the separator is correct."
On Error GoTo 0
End Function
So to use the UDF, if the date is diamesano = "2/5/14"
the day will be EXTRACTELEMENT(CStr(diamesano), 1, "/") where 1 is the 1st element that is the value 2
the month will be EXTRACTELEMENT(CStr(diamesano), 2, "/") where 2 is the 2nd element that is the value 5
the year will be EXTRACTELEMENT(CStr(diamesano), 3, "/") where 3 is the 3rd element that is the value 14
Code to use the UDF and check dates
And the code changes to:
diamesano = "12/18/2017"
dia = CLng(EXTRACTELEMENT(CStr(diamesano), 1, "/"))
mes = CLng(EXTRACTELEMENT(CStr(diamesano), 2, "/"))
ano = CLng(EXTRACTELEMENT(CStr(diamesano), 3, "/"))
Debug.Print "day: " & dia & " month: " & mes & " Year: " & ano
date_error = 0
If mes >= 1 And mes <= 12 Then 'Check if month is ok
mesAno = mes & "/" & ano
DiasNoMes = Day(DateSerial(Year(mesAno), Month(mesAno) + 1, 0))
If dia >= 1 And dia <= DiasNoMes Then 'Check the amount of days on this month and if is in range
Debug.Print "OK"
'Do something because the Date is valid!
Else
date_error = 1
End If
Else
date_error = 1
End If
If date_error = 1 Then
Debug.Print "NOK"
'Date is invalid =P
End If
Create UDF to check if the Date is right
Function IsDateRight(diamesano) As String
On Error GoTo ErrHandler:
dia = CLng(Split(Application.Trim(Mid(CStr(diamesano), 1)), "/")(0))
mes = CLng(Split(Application.Trim(Mid(CStr(diamesano), 1)), "/")(1))
ano = CLng(Split(Application.Trim(Mid(CStr(diamesano), 1)), "/")(2))
'Debug.Print "day: " & dia & " month: " & mes & " Year: " & ano
date_error = 0
If mes >= 1 And mes <= 12 Then 'Check if month is ok
mesAno = mes & "/" & ano
DiasNoMes = Day(DateSerial(Year(mesAno), Month(mesAno) + 1, 0))
If dia >= 1 And dia <= DiasNoMes Then 'Check the amount of days on this month and if is in range
IsDateRight = "Yes"
'Do something because the Date is valid!
Else
date_error = 1
End If
Else
date_error = 1
End If
If date_error = 1 Then
IsDateRight = "No"
'Date is invalid =P
End If
Exit Function
ErrHandler:
' error handling code
MsgBox "ERROR: Verify if the data exists, example if the separator is correct."
On Error GoTo 0
End Function
And a test:
I am having trouble finding the cause of the
Invalid procedure call or argument (Error 5)
that occurs on the last line of the table I am manipulating.
I have tried different tables of the same format and have found that they work just fine. This leads me to believe there is an issue with the specific row in the table
Relevant code:
VName.Value = RID.Value & " " & IIf(InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) <> 0 And _
(InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1) >= 10, _
Left(RID.Offset(columnOffset:=1).Value, InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1), RID.Offset(columnOffset:=1).Value)
Full Code:
'~~~> For Each Row
'~~~> ID Row (offset by 2 columns) with SectionTitle (Cache A3) + ID starting with 0 on the header
Set RID = Nothing
Set SecT = Range("'Values'!$A$3")
Set RCount = .Range(.Cells(HC, 2), .Cells(.Cells(Rows.count, 2).End(xlUp).Row, 2))
IDCount = 0
For Each RID In RCount
'ID Req rows
RID.Offset(columnOffset:=-1).Value = SecT.Value & " " & IDCount
'~~~> Add ID, ReqName, Section to Values sheet where if ID is 0 then Type = Folder
Set VSection = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 2)
VSection.EntireRow.ClearContents
Set VName = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 3)
Set VType = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 4)
Set VID = Worksheets("Values").Cells(Worksheets("Values").Cells(Rows.count, 2).End(xlUp).Row + 1, 5)
'Row = Header where IDCount = 0
If IDCount = 0 Then
VSection.Value = SecT.Value
VName.Value = SecT.Value
VType.Value = "Folder"
VID.Value = IDCount
'Row <> Header where IDCount > 0
ElseIf IDCount > 0 Then
VSection.Value = SecT.Value
VName.Value = RID.Value & " " & IIf(InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) <> 0 And _
(InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1) >= 10, _
Left(RID.Offset(columnOffset:=1).Value, InStr(1, RID.Offset(columnOffset:=1).Value, vbCrLf) - 1), RID.Offset(columnOffset:=1).Value)
VName.WrapText = False
VID.Value = IDCount
End If
IDCount = IDCount + 1
Next RID
RID.Value = FLO.1170
RID.Offset(columnOffset:=1).Value = WORKITEM MANAGEMENT
triggers a
Invalid procedure call or argument (Error 5)
As there are no line breaks within "WORKITEM MANAGEMENT" it should use the full cell value and not the Left function. The other 113 rows worked fine.
It would seem that the IIF is evaluating both of the conditions, not ignoring the second when the first is false. If And always evaluates both. If then If only evaluates the second if the first is true. I suspect that the second criteria is causing the crash because it is being evaluated regardless of whether the first is true or not (in this case not) and Left cannot have a negative length. Change the IIF to a pair of nested If statements.
It also appears that you're are trying to compare Left(<string>, <length>) to the number 10. This may not be correct. If text that looks like a number is being returned out of the Left method then wrap it in CLng() or CDbl() to get an actual number.
Perhaps a .Split function would be a better choice. If Split cannot find the delimiter to actually split something, you will still have the original value as the zero-based element.
VName.Value = RID.Value & " " & Split(RID.Offset(columnOffset:=1).Value, Chr(10))(0)
And thanks in advance for any help you can provide. I'm fairly new to VBA and this is outside of my current capability.
Ok, so I have raw data that is broken up by date and time in 30 minute intervals (Columns A, B). I have built a loop to find a specific segment (lines of data using Start Time, and Stop Time). What I am having issues with is pulling a timeframe for multiple days. The code is pulling the entire segment from start to end time, regardless of the date. So I end up with a large chunk of data that needs to be trimmed down.
Here is the code I'm using currently.
Key: *A2 = Start Date, *B2 = Start Time, *C2 = End Date, *D2 = End Time.
'============================================
' Date/Time lookup in Adjusted Table
'============================================
Sheets("Allotments (ADJ)").Select
i = 1
Do Until Cells(i, 1) = ""
If Cells(i, 1) = Sheets("macros").Range("a2") Then
Do Until Cells(i, 1) <> Sheets("macros").Range("a2")
If Cells(i, 2) = Sheets("macros").Range("b2") Then
startrow = i
End If
i = i + 1
Loop
End If
i = i + 1
Loop
i = 1
Do Until Cells(i, 1) = ""
If Cells(i, 1) = Sheets("macros").Range("c2") Then
Do Until Cells(i, 1) <> Sheets("macros").Range("c2")
If Cells(i, 2) = Sheets("macros").Range("d2") Then
endrow = i
End If
i = i + 1
Loop
End If
i = i + 1
Loop
Sheets("Allotments (ADJ)").Range("a" & startrow & ":l" & endrow).Copy
Sheets("macros").Select
Range("c3").Select
ActiveSheet.Paste
CutCopyMode = False
Is there a way I can modify this to grab only a desgnated timeframe for each day, if I'm trying to pull from multiple date range?
After tinkering with it for a long time and making the variables clearer I was able to get a working version.
StartDate = DateValue(StartDate)
EndDate = DateValue(EndDate)
Sheets("Allotments (ADJ)").Select
If StartDate = EndDate Then
datestart = 2
Do Until Range("A" & datestart) = ""
If Sheets("Allotments (ADJ)").Range("A" & datestart).Value = StartDate Then
StartTimerow = datestart
Do Until Range("B" & StartTimerow).Value = StartTime
StartTimerow = StartTimerow + 1
Loop
Endtimerow = StartTimerow
Do Until Range("B" & Endtimerow).Value = EndTime
Endtimerow = Endtimerow + 1
Loop
Exit Do
End If
datestart = datestart + 1
Loop
Sheets("Allotments (ADJ)").Range("a" & StartTimerow & ":N" & Endtimerow).Copy
Sheets("Macros").Select
Range("C1").Select
Range("c" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
CutCopyMode = False
End Sub
I am using excel 2007, ms visual basic 6.0.
I required to check the window os date format (e.g, whether is it using d/m/yyyy or m/d/yyyy), in order to using the following code.
Dim lastdateofmonth As Date
Dim lastwhichday As String
slastdayofmonth = "31"
'if the OS system is using m/d/yyyy then use this
lastdateofmonth = (sTxtMMM + "/" + slastdayofmonth + "/" + TxtYYYY)
lastwhichday = Weekday(lastdateofmonth)
'if th OS system is using d/m/yyyy then use this
lastdateofmonth = (slastdayofmonth+ "/" + sTxtMMM + "/" + TxtYYYY)
anyone can help? Thanks in advance
hmm... i found a better way
'========== Check OS Date format========
Dim OSDateFormatType As Integer
' 0 = month-day-year; 1 = day-month-year; 2 = year-month-day
If Application.International(xlDateOrder) = 0 Then
OSDateFormatType = 0
ElseIf Application.International(xlDateOrder) = 1 Then
OSDateFormatType = 1
ElseIf Application.International(xlDateOrder) = 2 Then
OSDateFormatType = 2
End If
But this only work for excel.
Check below code....
Sub getSystemDateFormat()
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
If isSheetExists(ThisWorkbook, "Temp") = False Then
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "Temp"
End If
ThisWorkbook.Sheets("Temp").Cells(1, 1) = ""
'On Error GoTo ErrHandle
'Get Date format
lngDateFormat = Application.International(xlDateOrder)
'Get Date Separator
strDateSeparator = Application.International(xlDateSeparator)
'Get leading 0 for day
If Application.International(xlDayLeadingZero) Then
strDayFormat = "dd"
Else
strDayFormat = "d"
End If
'Get leading 0 for month
If Application.International(xlMonthLeadingZero) Then
strMonthFormat = "mm"
Else
strMonthFormat = "m"
End If
'Get 4 digit/2 digit format for year
If Application.International(xl4DigitYears) Then
strYearFormat = "yyyy"
Else
strYearFormat = "yy"
End If
'Consolidate the values
If lngDateFormat = 0 Then ' Month-Day-Year
lngPos1 = InStr(1, Now(), strDateSeparator)
If lngPos1 = 4 Then
strMonthFormat = "mmm"
End If
strDateFormat = strMonthFormat & strDateSeparator & strDayFormat & strDateSeparator & strYearFormat
ElseIf lngDateFormat = 1 Then ' Day-Month-Year
lngPos1 = InStr(1, Now(), strDateSeparator)
lngPos2 = InStr(lngPos1 + 1, Now(), strDateSeparator)
If lngPos2 - lngPos1 = 4 Then
strMonthFormat = "mmm"
End If
strDateFormat = strDayFormat & strDateSeparator & strMonthFormat & strDateSeparator & strYearFormat
Else ' Year-Month-Day
lngPos1 = InStr(1, Now(), strDateSeparator)
lngPos2 = InStr(lngPos1 + 1, Now(), strDateSeparator)
If lngPos2 - lngPos1 = 4 Then
strMonthFormat = "mmm"
End If
strDateFormat = strYearFormat & strDateSeparator & strMonthFormat & strDateSeparator & strDayFormat
End If
MsgBox strDateFormat
EndLine:
ThisWorkbook.Sheets("Temp").Activate
ThisWorkbook.Sheets("Temp").Cells(1, 1) = strDateFormat
Exit Sub
ErrHandle:
If Err.Description <> "" Then
ThisWorkbook.Sheets("Temp").Cells(1, 1) = Err.Description
End If
ThisWorkbook.Sheets("Temp").Activate
End Sub
Function isSheetExists(wbk As Workbook, strSheetName As String) As Boolean
isSheetExists = False
For i = 1 To wbk.Sheets.Count
If wbk.Sheets(i).Name = strSheetName Then
isSheetExists = True
Exit For
End If
Next i
End Function
The best way:
if Application.International(xlMDY) then ...
True - month, day, year
False - day, month, year
https://msdn.microsoft.com/en-us/library/office/ff840213%28v=office.15%29.aspx