Adding additional rows under a row, depending on the amount of used cells in a range

Question

basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.

In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.

Ths is my current code:

Sub texttocolumns()

Dim rng As Range
Dim x As Integer

x = ActiveSheet.UsedRange.Rows.Count

For i = x - 2 To 1

Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True

    k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")

            Cells(2 + i, 1).Rows(k).Insert
Next i

End Sub

I can't find my mistake at the moment, could someone please help me out? thanks!

This line `k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")` does not make sense. Also since you are using VBA perhaps there would be a more direct approach to what you need to achieve that trying to do it the way you would do it manually. Suggest to give us a glance at your original data and the expected outcome, so we can provide a complete solution. — EEM, Nov 27 '17 at 14:45
thanks, I agree with you, it's probably impossible to fully understand what I mean. I will add more Information — StB, Nov 27 '17 at 14:54
Don't change your original question with pieces of the answers & comments you are receiving, it just gets confusing for new readers of your question, particularly if you don't know how to implement the changes. This line `For i = x - 2 To 1` does not work without the `Step` parameter. If you don't provide additional information you question might be closed. — EEM, Nov 27 '17 at 14:56

EEM · Accepted Answer · 2017-11-28T11:09:58.770

Since the output result is posted to a different location the expensive task of inserting rows can be avoided.

Try this procedure, which also avoids working with the source range by generating from it two Arrays:

An array containing the fixed fields
An array containing the field that needs to be split

The Procedure:

    Sub Range_Split_A_Field()
    Dim wsTrg As Worksheet, rgOutput As Range
    Dim aFld_1To5  As Variant, aFld_6 As Variant
    Dim aFld As Variant
    Dim lRow As Long, L As Long

        lRow = 3
        Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
        Application.Goto wsTrg.Cells(1), 1

        With wsTrg.Cells(lRow, 1).CurrentRegion
            Set rgOutput = .Rows(1).Offset(0, 10)
            .Rows(1).Copy
            rgOutput.PasteSpecial
            Application.CutCopyMode = False
            aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
            aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
        End With

        lRow = 1
        For L = 1 To UBound(aFld_1To5)
            aFld = aFld_6(L, 1)
            If aFld = vbNullString Then
                rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
                rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
                lRow = 1 + lRow

            Else
                aFld = Split(aFld, Chr(44))
                aFld = WorksheetFunction.Transpose(aFld)
                rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
                rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
                lRow = lRow + UBound(aFld)

        End If: Next

        End Sub

Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)

amazing, works so well. Unfortunately I don't understand what is happening at all, will take some time to try to understand the code. Thank you! — StB, Nov 28 '17 at 08:42
Read the pages provided, also if you debug the code line by line (using `[F8]`) then you'll see what each instruction does. Don't' forget to accept the answer that provides the best solution, helps us to keep the site updated. — EEM, Nov 28 '17 at 10:19

Darren Bartrup-Cook · Answer 2 · 2017-11-27T15:10:38.583

Would something like this work:

'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G

'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15

Sub Test()
    TextToColumns Sheet1.Range("A1")
    TextToColumns Sheet1.Range("A9"), "!"
End Sub

Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")

    Dim rng As Range
    Dim lCount As Long
    Dim x As Long

    'How many delimiters in target string?
    lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))

    'Add the blank rows.
    For x = 1 To lCount + 1
        Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Next x

    'Split the string.
    Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter

    'Use TRANSPOSE formula to paste to rows and then remove formula.
    With Target.Offset(1).Resize(lCount + 1, 1)
        .FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
        .Value = .Value
    End With

    'Delete the original text string.
    Target.EntireRow.Delete

End Sub

Edit:

To use from the Macro dialog box you could add this small procedure:

Public Sub Test()  

    Dim y As Long

    y = ActiveSheet.UsedRange.Rows.Count

    With ActiveSheet
        For y = 5 To 1 Step -1
            TextToColumns .Cells(y, 1)
        Next y
    End With

End Sub

Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA

The TextToColumns sub is not shown when I want to run a macro so I can't try that unfortunately — StB, Nov 27 '17 at 14:51
It won't appear in Macro dialog box as it's expecting arguments - it needs to know which cell to split, and whether it should expect commas or some other delimiter. `Test` will appear in the macro dialog and it will execute `TextToColumns` twice (once on cell A1, and once on cell A9). I'll add some code which will execute as your original code does... — Darren Bartrup-Cook, Nov 27 '17 at 15:06

Adding additional rows under a row, depending on the amount of used cells in a range

2 Answers2