excel vba date format into short date

bobbyexcel

Board Regular
Joined
Nov 21, 2019
Messages
84
Office Version
  1. 365
Platform
  1. Windows
Can someone help me on this please.. I'm try to run the following script however it is getting failed at line (lo.ListColumns("Final Status").DataBodyRange.Value = Result 'write array to listobject)

The reason is becoz of Date format. It works perfectly when I change the column date format(custom at this moment) into shortdate. but it is not working through vbscript. Please help me on this. This is the line I change the date to shortdate but no use.
RANGE("P" & Cell.Row).Value = FormatDateTime(RANGE("P" & Cell.Row).Value, vbShortDate)

1656273526293.png


VBA Code:
    Sheets("temp_sheet").Activate

    Dim ws As Worksheet, DateRng As RANGE, Cell As RANGE, Lastrow As Integer
    Set ws = Worksheets("temp_sheet")
    
    Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set DateRng = RANGE("A2:A" & Lastrow)
    
    If Lastrow > 1 Then
            RANGE("D2:D" & Lastrow).TextToColumns Destination:=RANGE("K2"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(3, 1), Array(7, 1), Array(10, 1), Array(19, 1), Array(23, 1)), TrailingMinusNumbers:=True
            RANGE("E2:E" & Lastrow).TextToColumns Destination:=RANGE("S2"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(3, 1), Array(7, 1), Array(10, 1), Array(19, 1), Array(23, 1)), TrailingMinusNumbers:=True
        For Each Cell In DateRng
            RANGE("P" & Cell.Row).Value = RANGE("L" & Cell.Row).Value & "/" & RANGE("K" & Cell.Row).Value & "/" & RANGE("O" & Cell.Row).Value
            RANGE("P" & Cell.Row).Value = FormatDateTime(RANGE("P" & Cell.Row).Value, vbShortDate)
            RANGE("Q" & Cell.Row).Value = Application.WorksheetFunction.Text(ws.RANGE("P" & Cell.Row), "mm-dd-yyyy") & " " & Application.WorksheetFunction.Text(ws.RANGE("M" & Cell.Row), "hh:mm:ss")
            RANGE("R" & Cell.Row).Value = TimeValue(RANGE("Q" & Cell.Row))
            RANGE("X" & Cell.Row).Value = RANGE("T" & Cell.Row).Value & "/" & RANGE("S" & Cell.Row).Value & "/" & RANGE("W" & Cell.Row).Value
            RANGE("X" & Cell.Row).Value = FormatDateTime(RANGE("X" & Cell.Row).Value, vbShortDate)
            RANGE("Y" & Cell.Row).Value = Application.WorksheetFunction.Text(ws.RANGE("X" & Cell.Row), "mm-dd-yyyy") & " " & Application.WorksheetFunction.Text(ws.RANGE("U" & Cell.Row), "hh:mm:ss")
            RANGE("Z" & Cell.Row).Value = TimeValue(RANGE("Y" & Cell.Row))
        Next Cell
    RANGE("K:O,S:W").Delete
    RANGE("L:L").Cut
    RANGE("N:N").Insert Shift:=xlToRight
    RANGE("O:O").Cut
    RANGE("Q:Q").Insert Shift:=xlToRight
    RANGE("K1").Value = "Start_Date_Converted_Format"
    RANGE("L1").Value = "Start_Time_Converted_Format"
    RANGE("M1").Value = "Start_Date_N_Time"
    RANGE("N1").Value = "End_Date_Converted_Format"
    RANGE("O1").Value = "End_Time_Converted_Format"
    RANGE("P1").Value = "End_Date_N_Time"
    RANGE("Q1").Value = "Final Status"
    RANGE("R1").Value = "Time Conversion"
    RANGE("S1").Value = "Rank"
    
    Dim NumFormat As Integer

    RANGE("R:R").NumberFormat = Number
    RANGE("R:R").NumberFormat = "0.0000"
    
    For NumFormat = 2 To Lastrow
        Cells(NumFormat, 18).Value = TimeValue(Cells(NumFormat, 16).Value)
    Next NumFormat

    End If


Dim ListObj As ListObject
Dim sTable As String

sTable = "DataTable"

   Set ListObj = ActiveSheet.ListObjects.Add(xlSrcRange, [A1].CurrentRegion, , xlYes)
   ListObj.Name = "TBL_Jobs_temp" 'The name for the table

   ' Dim format() As Double
    'Dim dict(mykey) As String

     Dim T_Start, T_Stop, Shift_Start, Shift_Stop, Result    'your 4 timestamps
     Set dict = CreateObject("scripting.dictionary")
     
    Dim lrr As Integer
    lrr = RANGE("I" & Rows.Count).End(3).Row

'     ActiveSheet.ListObjects.Add(xlSrcRange, RANGE("A1:S" & lrr), , xlYes).Name = "TBL_Jobs_temp"
     
     Set lo = Sheets("temp_sheet").ListObjects("TBL_Jobs_temp")     'table with your data
     arr = lo.DataBodyRange.Value2     'read that table to an array
     ReDim Result(1 To UBound(arr), 1 To 1)

     '1st ROUND : find last status at the end of the shift
    For i = 1 To UBound(arr)     'loop through data
          T_Start = arr(i, 11) + arr(i, 12)     'timestamp end of job
          T_Stop = arr(i, 14) + arr(i, 15)     'timestamp end of job
          mykey = arr(i, 7) & Format(arr(i, 11), "\|dd-mm-yyyy")     'job name & start date
          
        If arr(i, 11) = arr(i, 14) Then
          
            If T_Stop <= arr(i, 11) + TimeSerial(15, 0, 0) Then     'job must end before next day 3PM
               If Not dict.exists(mykey) Then
                    dict(mykey) = Array(T_Stop, arr(i, 10))
               Else
                    If dict(mykey)(0) < T_Stop Then dict(mykey) = Array(T_Stop, arr(i, 10))     '---> for that job and that startdate, the last endmoment & status
               End If
            Else
            '   MsgBox "Listrow " & i & vbTab & arr(i, 1) & vbTab & lo.DataBodyRange(i, 1).Address & vbLf & "job ran from " & Format(T_Start, "dd-mmm hh:mm") & " until " & Format(T_Stop, "dd-mmm hh:mm") & vbLf & "didn't stop before " & Format(arr(i, 3) + 1 + TimeSerial(15, 0, 0), "dd-mmm hh:mm")
               Result(i, 1) = "not within the shift"
          End If
     
                    
          Else
          
            If T_Stop <= arr(i, 11) + 1 + TimeSerial(15, 0, 0) Then     'job must end before next day 3PM
                 If Not dict.exists(mykey) Then
                      dict(mykey) = Array(T_Stop, arr(i, 10))
                 Else
                      If dict(mykey)(0) < T_Stop Then dict(mykey) = Array(T_Stop, arr(i, 10))     '---> for that job and that startdate, the last endmoment & status
                 End If
            Else
             '    MsgBox "Listrow " & i & vbTab & arr(i, 1) & vbTab & lo.DataBodyRange(i, 1).Address & vbLf & "job ran from " & Format(T_Start, "dd-mmm hh:mm") & " until " & Format(T_Stop, "dd-mmm hh:mm") & vbLf & "didn't stop before " & Format(arr(i, 3) + 1 + TimeSerial(15, 0, 0), "dd-mmm hh:mm")
                 Result(i, 1) = "not within the shift"
            End If
     
     
        End If
     
    Next

     '2nd ROUND : add status corresponding with status "end of shift"
     For i = 1 To UBound(arr)     'loop through data
          If Len(Result(i, 1)) = 0 Then     'no blocking conditions
               mykey = arr(i, 1) & Format(arr(i, 11), "\|dd-mm-yyyy")    'key within dictionary
               Result(i, 1) = dict(mykey)(1)     'last known status
          End If
     Next

     lo.ListColumns("Final Status").DataBodyRange.Value = Result     'write array to listobject
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
2,386
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
What error number and error message do you get? The format in the worksheet should never cause an error when code assigns data. Your assumption that problem is related to the format may be wrong.
 

bobbyexcel

Board Regular
Joined
Nov 21, 2019
Messages
84
Office Version
  1. 365
Platform
  1. Windows
It says type mismatch at line (Result(i, 1) = dict(mykey)(1) 'last known status)

1656316660739.png
 

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,092
Office Version
  1. 365
Platform
  1. Windows
I haven't run your code but firstly, is there any reason you have Set lo when you already have a variable ListObj ?
When it errors out can you go to Excel hit <F5> select the table name TBL_Jobs_temp, then hit enter.
Does it select the databody and have do you have more than 1 row in the selected area ?
 

Forum statistics

Threads
1,176,104
Messages
5,901,400
Members
434,890
Latest member
creativimama

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top