I'm having trouble understanding why VBA failed to compile here. I tried different changes, but the compile error turned to different errors. I'm trying to set the vardate as a date and varfund to fund so I can link it up to an updated Bloomberg formula (that part works). Can anyone help? Thanks
Sub Test()
Dim lastdate As Date
Dim Raw As Worksheet
Set Raw = Sheets("Raw")
lastdate = Raw.Range("A3")
'If lastdate < Date And Date - lastdate < 51 Then
'Do Until lastdate = Date
' lastdate = lastdate + 1
'If Weekday(lastdate, vbMonday) < 6 Then
' Rows(3).Insert
' Raw.Range("A3") = lastdate
' End If
' Loop
'End If
'=BDH($B$1, "PX_LAST", $A$13, $A$13) <-- Base formula
Dim vardate As Date
Dim varfund As String
Dim i As Integer 'Rows
Dim j As Integer 'Columns
For i = 1 To 50
For j = 1 To 100
vardate = Raw.Cells.Value(i + 2, 1) 'Defines the new date
varfund = Raw.Cells.Text(1, j + 1) 'Defines the fund variables
If Raw.Cells.Formula(i + 2, j + 1) = "" And varfund <> "" Then
Raw.Cells.Formula(i + 2, j + 1) = "=BDH(" & varfund & "," & Chr(34) & _
"PX_LAST" & Chr(34) & ", " & vardate & ", " & vardate & ")"
End If
Next j
Next i
End Sub
Related
I have a column in "dd-mm-yy hh:mm" format that formed as a result of some action on UserForm:
Dim ws as Worksheet
Set ws = Worksheets("Logs")
With ws
For i = 1 to Me.ListBox1.ListCount - 1
.Cells(lRow + 1 + i, 10).Value = CDate(VBA.Format(Me.ListBox1.List(i), "dd-mm-yy hh:mm"))
Next i
End With
I save the column to Variant variable to use later (to be used multiple times):
Dim arrTimeD As Variant
arrTimeD = Application.Transpose(.Range(TCL & "2:" & TCL & lRow).Value)
The locale date settings are European: "dd-mmm-yyyy"
The spreadsheet are used by different users, some have "dd-mmm" setting, others "mm-dd" etc.
I need to compare the dates in several uses. For, e.g.
Dim bDate as Date
bDate = CDate(VBA.Format(Me.lblCheckin.Caption,"dd-mm-yyyy"))
Do While CDate(arrTimeD(bIndex)) < bDate
If bIndex = lRow - 1 Then Exit Do
bIndex = bIndex + 1
Loop
When the user with US locale ("mm-dd") uses the spreadsheet, CDate(arrTimeD(bIndex)) throws error. CDate(VBA.Format(arrTimeD(bIndex))) and CDate(DateValue(arrTimeD(bIndex)) didn't help. What is the best way to do it?
Is it possible to set workbook's own date setting regardless of OS's?
Or I need to convert variant to string then concatenate?
The date string should be converted into a numeric date value.
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
Usage
Private Sub UserForm_Initialize()
Dim n As Long
For n = 1 To 100
ListBox1.AddItem Format(Date + n / 24, "MM-DD-YY HH:MM")
Next
End Sub
Public Function ListBoxDateValues()
Dim Data As Variant
ReDim Data(1 To Me.ListBox1.ListCount, 1 To 1)
Dim DateString As String
Dim r As Long
For r = 1 To Me.ListBox1.ListCount
DateString = Me.ListBox1.List(r - 1)
Data(r, 1) = DDMMYYYFormatToDateTimeValue(DateString)
Next
ListBoxDateValues = Data
End Function
Public Function wsLogs() As Worksheet
Set wsLogs = ThisWorkbook.Sheets("Logs")
End Function
Function DDMMYYYFormatToDateTimeValue(DateString As String) As Date
Dim Parts() As String
Parts = Split(DateString, "-")
DDMMYYYFormatToDateTimeValue = CDate(Parts(1) & "/" & Parts(0) & "/" & Parts(2))
End Function
First, true date values carry no format, so convert your text dates from the listbox directly to true date values:
.Cells(lRow + 1 + i, 10).Value = CDate(Me.ListBox1.List(i))
These you can apply the format you prefer for display.
The comparison is now straight:
Dim bDate As Date
bDate = CDate(Me.lblCheckin.Caption)
Do While arrTimeD(bIndex) < bDate
If bIndex = lRow - 1 Then
Exit Do
Else
bIndex = bIndex + 1
End If
Loop
My code run perfectly but when it comes to add duration more than 24 hours, the code return time of next day. Please see image:
For instance:
CELL(C3)-0500_1145-DURATION IS 6.45
CELL(D3)-CTC-THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(E3)-0500_1145-DURATION IS 6.45
CELL(F3)-0500_1145-DURATION IS 6.45----TOTAL
DURATION=6.45(C3)+6.45(E3)+6.45(F3)=20.15
CELL(G3) & CELL(I3)-OFF -THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(H3)-1000_1800(ACP)-DURATION IS 8
Although the code calculate the duration right here i.e 8 hours but when the system sum all the duration it should give 28:15 but the system is taking it as next day and return total duration as 4:15.
My issue is that how can i make the system to return 28 hours 15 mins(28:15) iso of 4:15 when duration is more than 24 hours.
Sub CalculateHourly()
Dim j As Long
Dim TextTime, wStart, wStop, midnight As String
Dim TrueTime, Temp As Date
Dim Parts As Variant
Dim lRow As Long
Application.Calculation = xlManual
midnight = "24" & ":" & "00"
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And Not IsEmpty(TextTime) Then
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = Left(Parts(0), 2) & ":" & Right(Parts(0), 2)
'wStop = Left(Parts(1), 2) & ":" & Right(Parts(1), 2)
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2)
Debug.Print ("test : " & Format(wStart, "h:mm;#"))
'If timeout is less than timein
If wStart > wStop Then
'Add 24 hours and make the diff
TrueTime = 24 + CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
Else
'if timeout greater than timein
TrueTime = CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
End If
**If (Temp + TrueTime) > 24 Then
TrueTime = 24 + Temp + TrueTime**
Else
TrueTime = Temp + TrueTime
End If
Temp = TrueTime
End If
Next j 'move to the number column in the same row
Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
Temp = Temp - Temp
Next i 'move to the next row
End Sub
Use a function like this to format to hours:minutes only:
Public Function FormatHourMinute( _
ByVal datTime As Date, _
Optional ByVal strSeparator As String = ":") _
As String
' Returns count of days, hours and minutes of datTime
' converted to hours and minutes as a formatted string
' with an optional choice of time separator.
'
' Example:
' datTime: #10:03# + #20:01#
' returns: 30:04
'
' 2005-02-05. Cactus Data ApS, CPH.
Dim strHour As String
Dim strMinute As String
Dim strHourMinute As String
strHour = CStr(Fix(datTime) * 24 + Hour(datTime))
' Add leading zero to minute count when needed.
strMinute = Right("0" & CStr(Minute(datTime)), 2)
strHourMinute = strHour & strSeparator & strMinute
FormatHourMinute = strHourMinute
End Function
Sub CalculateHourly2()
Dim j As Long
Dim TextTime As String, wStart As Date, wStop As Date, midnight As String
Dim Parts As Variant
Dim lRow As Long
Dim vArray() As Variant, n As Integer
Application.Calculation = xlManual
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
n = 0
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And TextTime <> "" Then '<~~ Unlike the case where the cell is empty, if you put an empty cell into a variable, it is not empty.
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = TimeValue(Left(Parts(0), 2) & ":" & Right(Parts(0), 2))
'wStop = TimeValue(Left(Parts(1), 2) & ":" & Right(Parts(1), 2))
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2) '<~~ Since other characters have been added, the mid sentence must be used.
n = n + 2
ReDim Preserve vArray(1 To n)
vArray(n - 1) = wStart
vArray(n) = wStop
End If
Next j 'move to the number column in the same row
'Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
If n > 0 Then
Cells(i, 10).Value = getTime(vArray)
Cells(i, 10).NumberFormat = "[hh]:mm"
End If
Next i 'move to the next row
End Sub
Function getTime(Other() As Variant)
Dim myTime As Date, s As Date, e As Date
Dim i As Integer
For i = LBound(Other) To UBound(Other) Step 2
s = Other(i)
e = Other(i + 1)
If s > e Then
e = e + 1
End If
myTime = myTime + e - s
Next i
getTime = myTime
End Function
Sheet Image
I am having issues to filter dates in a ListObject, as some of them get well sorted and others don't at all.
What I want exactly is to filter dates, take the one that is the closest to today and put it in an other ListObject (basically, the tool I am creating is a database where all important events are stored and I want to send the most recent in a ListObject). For the moment, in order to try things, I just put the filtered date in the column to the right.
Here is the a quick screenshot to explain :
So what I am doing is that I get the first column data. If I get the same reference multiples times, it means I have multiple events and I am trying to sort it using this code :
Sub derniereDate()
Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim lastRowS5 As Long
Dim lastDate As String
lastRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row
lastRowS5 = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 5 To lastRowS5 Step 1
lastDate = Format(Sheets(5).Range("M" & i), "MM/DD/YYYY")
While Sheets(5).Range("A" & i) = Sheets(5).Range("A" & i + j)
If lastDate < Sheets(5).Range("M" & i + j).Value Then
lastDate = Sheets(5).Range("M" & i + j)
End If
j = j + 1
Wend
If j <> 1 Then
Sheets(5).Range("P" & i) = lastDate
End If
i = i + (j - 1)
j = 1
Next i
End Sub
Here is a screenshot of a case where the sort doesn't work properly :
Excuse me for my English, thanks for help and staying up for more details if needed.
Sub derniereDate()
Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim lastRowS5 As Long
Dim lastDate As Date
lastRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row
lastRowS5 = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 5 To lastRowS5 Step 1
lastDate = Format(Sheets(5).Range("M" & i), "MM/DD/YYYY")
While Sheets(5).Range("A" & i) = Sheets(5).Range("A" & i + j)
If lastDate < Sheets(5).Range("M" & i + j).Value Then
lastDate = Sheets(5).Range("M" & i + j)
End If
j = j + 1
Wend
If j <> 1 Then
Sheets(5).Range("P" & i) = lastDate
End If
i = i + (j - 1)
j = 1
Next i
End Sub
Simply had to change lastDate type... Sorry for the useless post...
The problem is that it deletes values from both rows where the difference occurs.
It should delete values just from the top row where the difference occurs.
So I tried replacing ws.Cells(RowNo, 3) = " " with ws.Cells(FirstDate, 1) = " " but it doesen't do anything.
Any help would be greatly appreciated. Thanks!
Below is the code:
Sub CalculateDate()
Dim Result, RowNo As Long
Dim FirstDate, SecondDate As Date
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
RowNo = 2
Do Until ws.Cells(RowNo + 1, 2) = ""
FirstDate = ws.Cells(RowNo, 2)
SecondDate = ws.Cells(RowNo + 1, 2)
If DateDiff("d", FirstDate, SecondDate) < 2 Then
ws.Cells(RowNo, 3) = " "
End If
RowNo = RowNo + 1
Loop
End Sub
KEY:
Red = where difference between 2 dates <2days
Yellow = where the cell value should be blank
Blue = value should be blank Blue = where cells should not be deleted
may be you have to change
If DateDiff("d", FirstDate, SecondDate) < 2 Then
ws.Cells(RowNo, 3) = " "
End If
with
If DateDiff("d", FirstDate, SecondDate) < 2 Then
ws.Cells(RowNo, 3).ClearContents
RowNo = RowNo + 1
End If
Receiving an error when I run the code below. This worked last month, just seemed to stop working since I performed an update on Octobers data.
The script should grab data from Derek_Calc, which is a list of all logins on a daily basis to an application on the server. This data is then compressed to highlight how many people are logging in per hour on any given day.
The following line is used to set the date information for where the data will be added to the table and the dates for which to check in the DEREK_Calcs:
Set tempRange = target1.Range("B1706:B1736")
Sub PopulateConcurrency() 'for re-populating specific dates for the 'DEREK_Concurrency_Logins' sheet
'UPDATE THE DATE RANGE below!
Dim thisBook As Workbook
Dim target1 As Worksheet
Dim target2 As Worksheet
Dim dbSheetNames(1 To 2) As String
Dim cell As Variant
Dim cell2 As Variant
Dim searchDate As String
Dim firstColDate As Boolean
Dim userIdLoginCount As Long
Dim startHour As String
Dim endHour As String
Dim startDateTime As Date
Dim endDateTime As Date
Dim startDateHour As Date
Dim endDateHour As Date
Dim hourCounter As Integer
Dim startRange As Range
Dim endRange As Range
Dim tempString As String
Dim counter As Long
Dim userIds() As Long
Dim uniqueIds As Collection, c
Dim targCellRange As Range
Dim tempRange As Range
Dim tempRange2 As Range
dbSheetNames(1) = "DEREK_Concurrency_Logins"
dbSheetNames(2) = "DEREK_Calcs"
Set thisBook = ThisWorkbook
Set target1 = thisBook.Sheets(dbSheetNames(1))
Set target2 = thisBook.Sheets(dbSheetNames(2))
'prepare variables
userIdLoginCount = 0
hourCounter = 0
'de-activate re-calculations for this sheet as these will be updated later
target1.EnableCalculation = False
target2.EnableCalculation = False
'stop screen refreshing
Application.ScreenUpdating = False
Set tempRange = target1.Range("B1706:B1736") 'UPDATE THE DATE RANGE FROM COLUMN B Of THE 'DEREK_Concurrency_Logins' sheet
For Each cell In tempRange 'loop through each date in the DEREK_Concurrency_User_Logins sheet
searchDate = cell.Value
searchDate = Format(searchDate, "dd/mm/yyyy")
firstColDate = True
hourCounter = 0
For hourCounter = 0 To 16 'loop to next hour time range
'get start hour and end hour
startHour = target1.Cells(2, (3 + hourCounter))
startHour = Format(startHour, "hh:mm")
endHour = target1.Cells(2, (4 + hourCounter))
endHour = Format(endHour, "hh:mm")
'prepare variables
Erase userIds
Set uniqueIds = Nothing
Set uniqueIds = New Collection
userIdLoginCount = 0
counter = 0
With target2
Set tempRange2 = target2.Range("DEREK_LoginDaily")
For Each cell2 In tempRange2 'loop through each cell2 In DEREK_LoginDaily
If (StrComp(searchDate, cell2.Value) = 0) Then 'check for date match
If firstColDate = False Then
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
Else 'if firstColDate is True
startHour = target1.Cells(2, 2) 'code for 7am - 8am, set startHour to 07:00
endHour = target1.Cells(2, 4) 'set endHour to 08:00
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
'THIS IS WHERE THE ERROR IS :-(
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
End If 'end if firstColDate
End If 'end if a date match
Next cell2 'loop through each cell2 In DEREK_LoginDaily
End With
'get unique values by putting array into a collection
On Error Resume Next
For Each c In userIds
If Not IsEmpty(c) Then
uniqueIds.Add Item:=c, Key:=CStr(c)
End If
Next c
'populate target cell
Set targCellRange = cell
targCellRange.Offset(0, (2 + hourCounter)) = (uniqueIds.count)
firstColDate = False
Next hourCounter 'loop to next hour time range
firstColDate = True
Next cell 'loop through each date in the DEREK_Concurrency_User_Logins sheet
MsgBox "Complete"
End Sub
Not sure how, but this line is where the issue is:
startRange.Offset(0, 10).Length > 0
For a Range option you cannot have a length. I received some help and changed the line to this:
Len(startRange.Offset(0, 10).Value)
This is now populating correctly. The entire scripts job is to take a worksheet of data including login dates and times, and then populate another table detailing how many users were in the system on an hourly basis.
Thank you for the help everyone!