Forum Discussion
24 hour VBA not working
I have this line in a large VBA, that splits 26/05/2022 19:00:00 into 2 columns, based on the space so time in one column and date is in the other. However, as soon as it splits its shows as 7.00 with PM then split into a different column rather than the 24 hour format.
Columns("U:U").Select
Selection.TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Space:=True
I've tried adding in:
Columns("W:W").Select
Selection.NumberFormat = " [h]:mm"
and every other number format for time but for some reason despite starting as a 24hr format it changes it to a 12hr AM/PM despite there being no AM or PM in the original date. The problem isn't that it turns to an AM or PM, its that once the VBA is run, if I try and change it to an AM or PM format, it will put it as an AM format based on this new 12 hour format rather than the original time. Does anyone know a way of keeping the 24 hour format?
| Start Date | Start Time | End Date | End Time |
| 26/05/2022 06:40 | 26/05/2022 | 6:40 | AM |
| 26/05/2022 08:00 | 26/05/2022 | 8:00 | AM |
| 22/05/2022 18:40 | 22/05/2022 | 6:40 | PM |
| 22/05/2022 18:40 | 22/05/2022 | 6:40 | PM |
| 22/05/2022 19:09 | 22/05/2022 | 7:09 | PM |
| 25/05/2022 22:48 | 25/05/2022 | 10:48 | PM |
Strange. I copied/pasted your sample data into a worksheet and ran the following code.
Sub Macro1() Range("U:U").TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ :=Array(Array(1, 4), Array(2, 1)), TrailingMinusNumbers:=True End SubThis was the result:
(My system date format is yyyy-mm-dd)
I've spend hours looking online and apparently it just seems to happen to certain computers, can't see an obvious fix other than to change the code to a split VBA. How would I incorporate in the place of the red part of the code below, or a similar thing:
New code:
Dim x As Double, c As Range
For Each c In Selection
x = c
c = Int(x)
c.NumberFormat = "m/d/yyyy"
c.Offset(0, 1) = Format(x, "hh:mm")
c.Offset(0, 1).NumberFormat = "hh:mm"Current code:
Sub DoAll()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String
Dim Formulas() As Variant
'~~> This is the relevant sheet
Set ws = ThisWorkbook.Sheets("Clockings")
With ws
'Inserts Six Columns at C,D,E,F,G,H
.Range("C:H").EntireColumn.Insert
.Range("C1").Formula = "ID"
.Range("D1").Formula = "Description"
.Range("E1").Formula = "Shift"
.Range("F1").Formula = "Type"
.Range("G1").Formula = "MY"
.Range("H1").Formula = "B"
.Range("V:W").EntireColumn.Insert
.Range("Y:Z").EntireColumn.Insert
.Range("V1").Formula = "Start Date"
.Range("W1").Formula = "Start Time"
.Range("Y1").Formula = "End Date"
.Range("Z1").Formula = "End Time"
'Inserts specific formulae to cells V2 and W2
ReDim Formulas(1 To 2)
Formulas(1) = "=INT(U2)"
Formulas(2) = "=MOD(U2,1)"
.Range("V2:W2").Formula = Formulas
ReDim Formulas(1 To 2)
Formulas(1) = "=IF(X2="""","""",INT(X2))"
Formulas(2) = "=IF(X2="""","""",MOD(X2,1))"
.Range("Y2:Z2").Formula = Formulas
'Inserts specific formulae to cells C2,D2.E2.F2.G2 and H2
ReDim Formulas(1 To 6)
Formulas(1) = "=IFERROR(VLOOKUP(B2,'17 SO'!A:C,2,0),VLOOKUP(B2,'18 SO'!A:C,2,0))"
Formulas(2) = "=IFERROR(VLOOKUP(C2,'17 SO'!B:D,2,0),VLOOKUP(C2,'18 SO'!B:D,2,0))"
Formulas(3) = "=IF(AND(W2>='Reference Sheet'!$C$14,W2<='Reference Sheet'!$C$12),TEXT(V2-1,""ddd"")&"" ""&IF(AND(W2>='Reference Sheet'!$C$12,W2<'Reference Sheet'!$C$13),'Reference Sheet'!$D$12,'Reference Sheet'!$D$13),TEXT(V2,""ddd"")&"" ""&IF(AND(V2>='Reference Sheet'!$C$12,W2<'Reference Sheet'!$C$13),'Reference Sheet'!$D$12,'Reference Sheet'!$D$13))"
Formulas(4) = "=IF(ISNUMBER(SEARCH(""Sling"",D2)),""Sling/Lab"",IF(ISNUMBER(SEARCH(""Dress"",D2)),""NDT Dressing Support"",IF(ISNUMBER(SEARCH(""Downtime"",D2)),""Downtime"",IF(ISNUMBER(SEARCH(""jigs"",D2)),""Jigs"",IF(ISNUMBER(SEARCH(""NC"",C2)),""NCR"",IF(ISNUMBER(SEARCH(""M2"",C2)),""Change"",IF(ISNUMBER(SEARCH(""M3"",C2)),""Change"",""Earning"")))))))"
Formulas(5) = "=MID(C2,4,2)"
Formulas(6) = "=IF(ISNA(VLOOKUP(C2,'1811 SO'!B:B,1,FALSE)), ""III"", ""II"")"
.Range("C2:H2").Formula = Formulas
'Changes number format in Columns B and C to general
.Range("C:H").NumberFormat = "General"
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("C2:C" & LastRow).FillDown
.Range("D2:D" & LastRow).FillDown
.Range("E2:E" & LastRow).FillDown
.Range("F2:F" & LastRow).FillDown
.Range("G2:G" & LastRow).FillDown
.Range("H2:H" & LastRow).FillDown
.Range("V2:V" & LastRow).FillDown
.Range("W2:W" & LastRow).FillDown
.Range("Z2:Z" & LastRow).FillDown
.Range("Y2:y" & LastRow).FillDown
Columns("V:W").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Y:Z").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'delete column U
.Range("U:U").EntireColumn.Delete
.Range("W:W").EntireColumn.Delete
.Range("AI1").Formula = "Role"
.Range("AJ1").Formula = "Squad"
'Changes number format in Columns V to Time
.Range("V:V").NumberFormat = "hh:mm"
.Range("X:X").NumberFormat = "hh:mm"
.Range("U:U").NumberFormat = "dd/mm/yyyy"
.Range("W:W").NumberFormat = "dd/mm/yyyy"
'Inserts specific formulae to cells AI2 and AJ2
ReDim Formulas(1 To 2)
Formulas(1) = "=VLOOKUP(AG2,'Employee Info'!A:C,3,0)"
Formulas(2) = "=VLOOKUP(AH2,'Employee Info'!B:D,3,0)"
.Range("AI2:AJ2").Formula = Formulas
'Changes number format in Columns AI and AJ to general
.Range("AI:AJ").NumberFormat = "General"
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("AI2:AI" & LastRow).FillDown
.Range("AJ2:AJ" & LastRow).FillDown
lr = Cells(Rows.Count, "C").End(xlUp).Row 'find last row
For i = lr To 2 Step -1 'loop thru backwards, finish at 2 for headers
If Cells(i, "C").Text = "#N/A" Then Rows(i).EntireRow.Delete
Next i
lrU = Cells(Rows.Count, "U").End(xlUp).Row 'find last row
LrV = Cells(Rows.Count, "V").End(xlUp).Row 'find last row
For i = lrU To 2 Step -1 'loop thru backwards, finish at 2 for headers
'column "U" is column21
If Cells(i, 21).Value < Worksheets("Summary").Cells(3, 7).Value And _
Cells(i, 22).Value < Worksheets("Reference Sheet").Cells(12, 4).Value Or _
Cells(i, 21).Value > Worksheets("Summary").Cells(3, 10).Value And _
Cells(i, 22).Value > Worksheets("Reference Sheet").Cells(13, 4).Value Then
Rows(i).EntireRow.Delete
End If
Next i
End With
End SubCould you attach a sample workbook (without sensitive data), or if that is not possible, make it available through OneDrive, Google Drive, Dropbox or similar? Thanks in advance.
