Excal-VBA: Convert a string of number numbers to rows and add recurrent name after


I have an issue which I use a lot of manual time on currently.

I have following simple data:

enter image description here

And I wish to convert all the accounts downwards with the name next to the accounts in another coloumn. Currently I do this by using the 'text to columns' function and then manually copy the names down.. HARD work.. :)

This is an example of my wish scenario..

enter image description here

Hope you are able to help..

Thanks a lot Kristoffer

Show source
| excel-vba   | vba   | excel   | excel-formula   2017-01-04 23:01 2 Answers

Answers ( 2 )

  1. 2017-01-05 00:01

    Try this

    Option Explicit
    Sub Test()
        Dim rng As Excel.Range
        Set rng = ThisWorkbook.Worksheets.Item(1).Cells(1, 1).CurrentRegion
        Set rng = rng.Offset(1)
        Set rng = rng.Resize(rng.Rows.Count - 1)
        Dim vPaste
        Dim lTotalRows As Long
        Dim lPass As Long
        For lPass = 0 To 1
            Dim rowLoop As Excel.Range
            For Each rowLoop In rng.Rows
                Dim sName As String
                sName = rowLoop.Cells(1, 1)
                Dim sAccounts As String
                sAccounts = rowLoop.Cells(1, 2)
                Dim vSplitAccounts As Variant
                vSplitAccounts = VBA.Split(sAccounts, ";")
                If lPass = 0 Then
                    lTotalRows = lTotalRows + UBound(vSplitAccounts) + 1
                    Dim vLoop As Variant
                    For Each vLoop In vSplitAccounts
                        lTotalRows = lTotalRows + 1
                        vPaste(lTotalRows, 1) = sName
                        vPaste(lTotalRows, 2) = vLoop
                    Next vLoop
                End If
            If lPass = 0 Then
                ReDim vPaste(1 To lTotalRows, 1 To 2)
                lTotalRows = 0
            End If
        ThisWorkbook.Worksheets.Item(2).Cells(1, 1).Value = "Name"
        ThisWorkbook.Worksheets.Item(2).Cells(1, 2).Value = "Account"
        Dim rngPaste As Excel.Range
        Set rngPaste = ThisWorkbook.Worksheets.Item(2).Cells(2, 1).Resize(lTotalRows, 2)
        rngPaste.Value2 = vPaste
    End Sub
  2. 2017-01-05 00:01

    The following short macro will take data from Sheet1 and output records in Sheet2:

    Sub DataReorganizer()
        Dim i As Long, j As Long, N As Long
        Dim s1 As Worksheet, s2 As Worksheet
        Set s1 = Sheets("Sheet1")
        Set s2 = Sheets("Sheet2")
        N = s1.Cells(Rows.Count, "A").End(xlUp).Row
        j = 1
        For i = 2 To N
            v1 = s1.Cells(i, 1)
            ary = Split(s1.Cells(i, 2), ";")
            For Each a In ary
                s2.Cells(j, 1).Value = v1
                s2.Cells(j, 2).Value = a
                j = j + 1
            Next a
        Next i
    End Sub


    enter image description here

    and output:

    enter image description here

◀ Go back