Excel VBA convert data from one cell into rows (type mismatch error)

Question

Im creating a macro VBA excel for the first time. I have the table that contains 4 columns as follows:

Determining the Geometry of Boundaries of Objects from Medial Data |    James N. Damon   |    907547    |   396035:835253:907794

And I want to separate them so that the output is:

Determining the Geometry of Boundaries of Objects from Medial Data |    James N. Damon   |    907547    |   396035

Determining the Geometry of Boundaries of Objects from Medial Data |    James N. Damon   |    907547    |   835253

Determining the Geometry of Boundaries of Objects from Medial Data |    James N. Damon   |    907547    |   907794

The macro that I used is as follows (from references in stackoverflow) but I have a type mismatch error on line

[e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)

Any help would be really appreciated. This is my first time dealing with VBA and it seems pretty blank to me about the type mismatch.

Sub SliceNDice()
    Dim objRegex As Object
    Dim X
    Dim Y
    Dim lngRow As Long
    Dim lngCnt As Long
    Dim tempArr() As String
    Dim strArr
    Set objRegex = CreateObject("vbscript.regexp")
    objRegex.Pattern = "^\s+(.+?)$"
     'Define the range to be analysed
    X = Range([a1], Cells(Rows.Count, "d").End(xlUp)).Value2
    ReDim Y(1 To 4, 1 To 1000)
    For lngRow = 1 To UBound(X, 1)
         'Split each string by ","
        tempArr = Split(X(lngRow, 4), ",")
        For Each strArr In tempArr
            lngCnt = lngCnt + 1
             'Add another 1000 records to resorted array every 1000 records
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 4, 1 To lngCnt + 1000)
            Y(1, lngCnt) = X(lngRow, 1)
            Y(2, lngCnt) = X(lngRow, 2)
            Y(3, lngCnt) = X(lngRow, 3)
            Y(4, lngCnt) = objRegex.Replace(strArr, "$1")
        Next
    Next lngRow
     'Dump the re-ordered range to columns E:H
    [e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)
    ActiveSheet.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlNo
End Sub

And my file is consists of hundred and thousands of rows.

Answer 1

Here is one way. Not the fastest but does the job. I have commented the code so you will not have a problem understanding it.

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, j As Long
    Dim tmpAr As Variant

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get last row in Col D. That is where we have to check for ":"
        lRow = .Range("D" & .Rows.Count).End(xlUp).Row

        '~~> Reverse loop the rows
        For i = lRow To 1 Step -1
            '~~> Check if cell in Col D has ":"
            If InStr(1, .Range("D" & i).Value, ":") Then
                '~~> Split on ":" and store in an array
                tmpAr = Split(.Range("D" & i).Value, ":")

                '~~> Loop through the array
                For j = LBound(tmpAr) To UBound(tmpAr)
                    '~~> Insert a row in the next row
                    .Rows(i + 1).Insert Shift:=xlDown, _
                    CopyOrigin:=xlFormatFromLeftOrAbove
                    '~~> Copy data from above as cell in Col D is different
                    .Rows(i).Copy .Rows(i + 1)
                    '~~> Add the new value to cell in Col D
                    .Cells(i + 1, 4).Value = tmpAr(j)
                Next j
                '~~> Delete the row
                .Rows(i).Delete
            End If
        Next i
    End With
End Sub

Screenshot