Multiple rows to single rows

[qiyusi]

Hello

I have questions,

I have code to transpose multiple rows into single rows, it not 100% work,

Sub splitthem()
Dim Rng As Range, Dn As Range, ray(), Txt As String, t
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
For Each Dn In Rng
    If Not temp = Dn And Dn <> "" Then
        Set temp = Dn
        c = c + 1
    End If
    ReDim Preserve ray(1 To 2, 1 To c)
    ray(1, c) = temp: ray(2, c) = ray(2, c) & " " & Dn.Offset(, 1).Value
Next Dn
Range("G1").Resize(c, 2) = Application.Transpose(ray)
End Sub

as there are at least two problem:
1. the result is in single cell separate by comma, i need the result in separate column
2. the last data not show properly, in example, the letter G is not show up.

Would be great if you can review what's wrong with the code.

sample file attached.

Thank you for the help.

[Marc L]

Hi !

1. the result is in single cell separate by comma,
i need the result in separate column

Just use TextToColumns method as explained in VBA inner help …

[mike7952]

This will work

Sub splitthem()
 Dim aBefore, i As Long, key, tmp
 
 aBefore = Range("a3", Cells(Rows.Count, 3).End(xlUp))
 With CreateObject("scripting.dictionary")
    For i = 1 To UBound(aBefore)
        If Not .exists(aBefore(i, 1)) And Not IsEmpty(aBefore(i, 1)) Then
            tmp = aBefore(i, 1)
            .Item(tmp) = tmp & "|" & aBefore(i, 3)
        Else
            .Item(tmp) = .Item(tmp) & "|" & aBefore(i, 3)
        End If
    Next
    i = 7
    For Each key In .keys
        tmp = Split(.Item(key), "|")
        Cells(i, "H").Resize(, UBound(tmp) + 1) = tmp
        i = i + 1
    Next
 End With
End Sub