Altering the existing macro to get date as numerical va;ue

Hi everyone,

I use a Macro (code attached) to flatten my dataset for dates (From vertical to Horizontal). Sample file is attached. However, in the resulting file dates appear as text and therefore, does not allow me to upload and use it with other softwares like SPSS for further analysis. Can someone please help me change the Macro code so that in the resultant file I get dates as numerical?

Thank you

Option Explicit
Sub abc()
 Const cShName As String = "sheet1"
 Dim aArr, e, x, i As Long

 With Sheets(cShName)
    aArr = .Range("a1").CurrentRegion.Value
 End With
 Worksheets.Add
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(aArr)
        If Not .exists(aArr(i, 1)) Then
            .Item(aArr(i, 1)) = Join(Array(aArr(i, 1), aArr(i, 2), aArr(i, 3), aArr(i, 4), aArr(i, 5)), "|")
        Else
            .Item(aArr(i, 1)) = Join(Array(.Item(aArr(i, 1)), aArr(i, 5)), "|")
        End If
    Next
    
    i = 1
    For Each e In .keys
        x = Split(.Item(e), "|")
        Cells(i, "a").Resize(, UBound(x) + 1) = x
        i = i + 1
    Next
 End With
End Sub

Not sure what you mean by "dates as numerical". Your problem may be easily fixed by switching the cell formatting away from your current custom setting and to the date format you desire. In other words, I don't think the vba code is the problem, I think it's the cell "Number" formatting.

Hi Gyclone,

I want dates as numbers and not as text. The current problem is after using the Macro, my dates get converted into text. In this new attachment labelled as "Attendance after Macro" , I have used Macro to make it more clear. Column M, which is highlighted shows that the dates are not read as numbers now. Therefore, I cannot use them for any calculations because they are treated as string variable in SPSS.

Regrading manual formatting: I tried using format option. It is feasible to use it with small number of cases. However, my problem with that is that I have huge dataset like 20,000 cases and 600 columns. It takes a lot of time to format every cell and if used together, the excel crashes every time.

Thanks,
Ajang

Try this...

Sub abc()
 Const cShName As String = "sheet1"
 Dim aArr, e, x, i As Long
 
 With Sheets(cShName)
    aArr = .Range("a1").CurrentRegion.Value
 End With
 Worksheets.Add
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(aArr)
        If Not .exists(aArr(i, 1)) Then
            .Item(aArr(i, 1)) = Join(Array(aArr(i, 1), aArr(i, 2), aArr(i, 3), aArr(i, 4), aArr(i, 5)), "|")
        Else
            .Item(aArr(i, 1)) = Join(Array(.Item(aArr(i, 1)), aArr(i, 5)), "|")
        End If
    Next
    
    i = 1
    For Each e In .keys
        x = Split(.Item(e), "|")
        Cells(i, "a").Resize(, UBound(x) + 1) = x
        i = i + 1
    Next
 End With
 Cells.Replace What:="/", Replacement:="/", LookAt:=xlPart
 Columns.AutoFit
End Sub

The Replace function coerces the text-dates into serial-dates.

Hi ajang,

I see from your spreadsheet what format you want, but, just so you'll understand my question, there are many, many ways that dates can be displayed as numbers (1/2/2013, 2013/1/2, 01/02/2013, 01-02-13, etc., etc.). In the future, you could save a step by including the actual format you want in your original post.

As for how to accomplish it, you need to select the appropriate range and change the number format, which you can do via vba (you don't have to do it manually).

Option Explicit
Sub abc()
 Const cShName As String = "sheet1"
 Dim aArr, e, x, i As Long

 With Sheets(cShName)
    aArr = .Range("a1").CurrentRegion.Value
 End With
 Worksheets.Add
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(aArr)
        If Not .exists(aArr(i, 1)) Then
            .Item(aArr(i, 1)) = Join(Array(aArr(i, 1), aArr(i, 2), aArr(i, 3), aArr(i, 4), aArr(i, 5)), "|")
        Else
            .Item(aArr(i, 1)) = Join(Array(.Item(aArr(i, 1)), aArr(i, 5)), "|")
        End If
    Next
    
    i = 1
    For Each e In .keys
        x = Split(.Item(e), "|")
        Cells(i, "a").Resize(, UBound(x) + 1) = x
        i = i + 1
    Next
 End With

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim lastrow As Long
    lastrow = ws.Range("e2").CurrentRegion.Rows.Count
    Dim lastcol As Long
    lastcol = ws.Range("e2").CurrentRegion.Columns.Count
    Dim rng As Range
    
    Set rng = ws.Range("e2:" & ws.Cells(lastrow, lastcol).Address)
    rng.NumberFormat = "m/d/yyyy;@"

    Set rng = nothing
    Set ws = nothing




End Sub

Try this

Sub test()
    Dim a, i As Long, ii As Long, txt As String, n As Long, maxCol As Long, w
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If Not .exists(txt) Then
                n = n + 1: .Item(txt) = VBA.Array(n, 4)
                For ii = 1 To 4
                    a(n, ii) = a(i, ii)
                Next
            End If
            w = .Item(txt): w(1) = w(1) + 1
            If w(1) > UBound(a, 2) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
            End If
            a(w(0), w(1)) = a(i, 5)
            .Item(txt) = w
            maxCol = Application.Max(maxCol, w(1))
        Next
    End With
    With Sheets.Add().Cells(1).Resize(n, maxCol)
        .Value = a
        .Columns.AutoFit
    End With
End Sub