I have a macro to fill dates background if they are not forward than today. It works nicely but, however, just in one page, DateValues are not compared correctly.
I tried to show the result with MessageBoxes, it says 16.06.2016 is bigger than 29.10.2016
My macro:
Sub DolguRenkleri(ByVal StartIndex As Integer, ByVal EndIndex As Integer)
Dim Tarih As String
Dim Formul As String
Dim Formul2 As String
Tarih = Left(Now, 10)
For i = StartIndex To EndIndex - 1
MsgBox (Cells(i, 2).Value > DateValue(Tarih))
If Cells(i, 2) <= DateValue(Tarih) Then
With Range("A" + CStr(i), "H" + CStr(i))
.Interior.ColorIndex = 6
End With
Formul = "=TOPLA(D" + CStr(i + 1) + ":D" + CStr(EndIndex - 1) + ")"
Formul2 = "=F6-A" + CStr(i)
Else: With Range("A" + CStr(i), "H" + CStr(i))
.Interior.ColorIndex = 2
End With
End If
Next i
Range("F1").FormulaLocal = Formul
Range("F7").FormulaLocal = Formul2
End Sub
it must be that "16.06.2016" string in cell B10 is not recognized as a real Date value, notwithstanding you may have selected that cell and assigned it a "Date" format
in this case, use
If DateValue(Replace(Cells(i, 2).Value, ".", "/")) <= DateValue(Tarih) Then
Related
I am trying to overwrite wrong Excel formula.
I copied the formula from the cell into the code and placed double quotes.
Already read that I have to type two times " for getting a " into the formula. I can't tell what is really going on, because of companies compliance but the code should do it.
Imagine there are 180 components with the same 18 function in cells. By deleting some components I lost the reference and instead of writing every formula again, I try to do this with VBA.
Sub nachtrag()
Dim i As Integer
Dim j As Integer
Dim Start As Integer
Start = 4
Dim Bezug As Integer
For i = 0 To 179
Bezug = Worksheets("QK-Daten").Range("R" & ((i * 18) + 18) + Start).Value
For j = 1 To 17
Worksheets("QK-Daten").Range("Z" & j + (i * 18) + Start).Value = "=WENN(R" & Bezug & "="""";"""";SVERWEIS(R" & Bezug & ";'QK-Tabelle'!$B$3:$C$123;2;FALSCH))*(R" & j + (i * 18) + Start & "/R" & Bezug & ")+((N" & j + (i * 18) + Start & "+O" & j + (i * 18) + Start & ")*0,3+(P" & j + (i * 18) + Start & "+Q" & j + (i * 18) + Start & ")*0,1)"
Next j
Worksheets("QK-Daten").Range("z" & ((i * 18) + 18) + Start).Copy
Worksheets("QK-Daten").Range("z" & ((i * 18) + 18) + Start).PasteSpecial Paste:=xlValues
Next i
End Sub
Try writing the formula with placeholders in the string and then use Replace() to substitute the values.
Option Explicit
Sub nachtrag()
Dim ws As Worksheet, cell As Range, s As String
Dim Bezug As Long, Start As Long
Dim i As Long, j As Long, r As Long
' formula
Const F = "=IF(R<bezug>="""";"""";VLOOKUP(R<bezug>;'QK-Tabelle'!$B$3:$C$123;2;FALSE))" & _
"*(R<r>/R<bezug>)+((N<r>+O<r>)*0,3+(P<r>+Q<r>)*0,1)"
Start = 4
Set ws = Worksheets("QK-Daten")
With ws
Set cell = .Range("R" & Start)
For i = 0 To 179
Bezug = cell.Offset(18).Row 'Value
For j = 1 To 17
r = j + (i * 18) + Start
s = Replace(F, "<bezug>", Bezug)
s = Replace(s, "<r>", r)
cell.Offset(j, 8).Formula = s 'Z
Next j
' not sure what this is doing
' .Range("z" & ((i * 18) + 18) + Start).Copy
' .Range("z" & ((i * 18) + 18) + Start).PasteSpecial Paste:=xlValues
cell.Offset(18, 8).Value = cell.Offset(18, 8).Value
' next component
Set cell = cell.Offset(18)
Next i
End With
MsgBox "Done", vbInformation
End Sub
below is a VBA that when launched I get an error code of 'Run-Time error '13: Type Mismatch'.
It had worked perfectly before for General Format "dd mmm yyyy hhmm". After a couple of other VBAs it now in a Custom Format "dd mmm yyyy hhmm". The end goal is to have a blank row inserted where a date is skipped over, and have "NO DEPARTURS" placed in the blank row Column A, and for Column B and C have "N/A", and for Column D input the Missing Date in "dd mmm yyyy 0000". When debugged the line beginning with d1= cdate... is highlighted.
Sub Missing_date()
Dim d1 As Date, d2 As Date
r = 1
start:
If Cells(r + 1, "D") = "" Then Exit Sub
d1 = CDate(Split(Cells(r, "D"), " ")(1) & ", " & Split(Cells(r, "D"), " ")(0) & " " & Split(Cells(r, "D"), " ")(2))
d2 = CDate(Split(Cells(r + 1, "D"), " ")(1) & ", " & Split(Cells(r + 1, "D"), " ")(0) & " " & Split(Cells(r + 1, "D"), " ")(2))
If d2 - d1 >= 2 Then
Rows(r + 1).Insert shift:=xlDown
Cells(r + 1, "D") = Format(d1 + 1, "dd mmm yyyy 0000")
Cells(r + 1, "A") = "NO DEPARTURES"
Cells(r + 1, "B") = "N/A"
Cells(r + 1, "C") = "N/A"
End If
r = r + 1
GoTo start
End Sub
You are going to an awful lot of trouble trying to handle dates your own way rather than what Excel would like. I have taken the liberty of presuming that you had no intention of declaring war on Excel. Please try this code.
Option Explicit
Sub InsertMissingDates()
' 111
Dim NextDate As Variant
Dim CellVal As Variant
Dim R As Long ' loop counter: Rows
R = Cells(Rows.Count, "D").End(xlUp).Row
NextDate = CellDate(Cells(R, "D"))
If NextDate = vbError Then Exit Sub
' bottom rows must be inserted before top rows
For R = R - 1 To 2 Step -1
CellVal = CellDate(Cells(R, "D"))
If CellVal = vbError Then Exit For ' exit if date can't be recognised
Do While Int(CDbl(CellVal)) < Int(CDbl(NextDate - 1))
Rows(R + 1).Insert Shift:=xlDown
With Cells(R + 1, "D")
.Value = Int(CDbl(NextDate - 1))
.NumberFormat = "dd mmm yyyy hhmm"
.HorizontalAlignment = xlLeft
End With
Cells(R + 1, "A").Value = "NO DEPARTURES"
Cells(R + 1, "B").Value = "N/A"
Cells(R + 1, "C").Value = "N/A"
NextDate = NextDate - 1
Loop
NextDate = CellVal
Next R
End Sub
Private Function CellDate(Cell As Range) As Variant
' 111
' return vbError if cell's value couldn't be converted to a date
Dim Fun As Variant ' function return value
Dim CellVal As Variant
Dim Sp() As String
CellVal = Cell.Value
If IsDate(CellVal) Then
Fun = CDate(CellVal)
Else
Sp = Split(CellVal, " ")
If UBound(Sp) = 3 Then
Sp(3) = Right("0000" & Sp(3), 4)
Sp(3) = Left(Sp(3), 2) & ":" & Right(Sp(3), 2)
On Error Resume Next
Fun = CDate(Join(Sp))
End If
End If
If VarType(Fun) <> vbDate Then
MsgBox """" & CellVal & """ in row " & Cell.Row & vbCr & _
"couldn't be converted to a date.", _
vbInformation, "Data format error"
Fun = vbError
End If
CellDate = Fun
End Function
The point is that Excel takes a date to be an integer number, like 44135. Tomorrow will be 44136. Therefore each day = 1 and, therefore, each hour = 1/24. 44135.0 is 12AM and 43135.5 denotes 12PM. To display these numbers like 31 Oct 2020 1200 you don't format the number but you format the cell. This is what my code does.
Now you will have cells in your worksheet which have text that looks like a date (your entries) and dates that look like text (entries made by my code). Consider concocting a procedure which looks at the NumberFormat of each cell and changes its value to a proper date if it's Text, applying the reqired format at the same time. You can use lines of code from my above procedures to put it together. Then the function CellDate would become obsolete because its sole job is to mediate between your text dates and Excel's intentions.
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
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
I am trying to export data from a excel to word but something goes wrong at the begging of the while statement. For some reason I get an error at the line ReDim Preserve zPList(zIndex) As personClass, the error is Subscript out of range.
Can someone help please?
Public Sub GetExcelData(ByRef zPList() As personClass, ByRef zIndex As Integer)
Dim tempStr As String
tempStr = ""
Dim row As Integer
row = 2
While tempStr <> "zzz"
zindez = zIndex + 1
ReDim Preserve zPList(zIndex) As personClass
Set zPList(zIndex) = New personClass
Range("A" + CStr(row)).Select
zPList(zIndex).fname = ActiveCell.text
Range("B" + CStr(row)).Select
zPList(zIndex).lname = ActiveCell.text
Range("C" + CStr(row)).Select
zPList(zIndex).Email = ActiveCell.text
Range("D" + CStr(row)).Select
zPList(zIndex).phoneN = ActiveCell.text
row = row + 1
Range("A" + CStr(row)).Select
tempStr = ActiveCell.text
Wend
End Sub