Data Formatting

[TabulaRasa]

Hello Everyone! I'm having a bit of trouble with formatting a fairly large data set. Currently, there are ~10,000 rows of data. Each row has the following information format in it:

[TABLE="class: grid, width: 1000"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]TEXT[/TD]
[TD]DATE[/TD]
[TD]DATE[/TD]
[TD]TEXT[/TD]
[TD]GENERAL (INCLUDES NUMBERS)[/TD]
[TD]TEXT[/TD]
[TD]CURRENCY[/TD]
[TD]TEXT (INCLUDES NUMBERS)[/TD]
[TD]No [2], Yes [3], etc.[/TD]
[TD]Yes [3], No [2], etc.[/TD]
[TD]TEXT [123.1], TEXT [123.5], etc.[/TD]
[/TR]
</tbody>[/TABLE]


The goal is to take columns I-K and make them multiple rows, with the data staying relative between the columns (for example, the above would be the following:[TABLE="class: grid, width: 1000"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]TEXT[/TD]
[TD]DATE[/TD]
[TD]DATE[/TD]
[TD]TEXT[/TD]
[TD]GENERAL (INCLUDES NUMBERS)[/TD]
[TD]TEXT[/TD]
[TD]CURRENCY[/TD]
[TD]TEXT (INCLUDES NUMBERS)[/TD]
[TD]No [2][/TD]
[TD]Yes [3][/TD]
[TD]TEXT [123.1][/TD]
[/TR]
[TR]
[TD]TEXT[/TD]
[TD]DATE[/TD]
[TD]DATE[/TD]
[TD]TEXT[/TD]
[TD]GENERAL (INCLUDES NUMBERS)[/TD]
[TD]TEXT[/TD]
[TD]CURRENCY[/TD]
[TD]TEXT (INCLUDES NUMBERS)[/TD]
[TD]Yes [3][/TD]
[TD]No [2][/TD]
[TD]TEXT [123.5][/TD]
[/TR]
</tbody>[/TABLE]


There are two additional complications. The first is that columns A-H need to be duplicated along with the now separated information from columns I-K (as it is identifying information). The second complication is that the TEXT information in column K contains commas, (for example: obesity, adult) so any comma delimited approach that I could think of will not work.

Hopefully this explains the issue and the goal well enough! I really appreciate everyone's assistance.

 

[ndsutherland]

Try

Sub testingtestingtwo()
Dim isplit, jsplit, ksplit
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
    isplit = Split(Range("I" & i), ", ")
    jsplit = Split(Range("J" & i), ", ")
    ksplit = Split(Range("K" & i), ", ")
    If UBound(isplit) > 0 Then
        For j = UBound(isplit) To LBound(isplit) Step -1
            Rows(i).Copy
            Rows(i + 1).Insert xlDown
            Application.CutCopyMode = False
            Range("I" & i + 1) = isplit(j)
            Range("J" & i + 1) = jsplit(j)
            Range("K" & i + 1) = ksplit(j)
        Next j
        Rows(i).Delete xlUp
    End If
Next i
End Sub

 

[TabulaRasa]

That locked up my Excel for ~10 minutes before giving a runtime error

 

[ndsutherland]

My appologies. I didn't think about how long inserting rows takes (time increases exponentially with number of rows)

This method takes about 5 seconds on 600 rows.

Sub testingtestingtwo()
Dim isplit, jsplit, ksplit, urange As Long, newrow As Long, i As Long, j As Long
Application.ScreenUpdating = False


urange = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To urange
    isplit = Split(Range("I" & i), ", ")
    jsplit = Split(Range("J" & i), ", ")
    ksplit = Split(Range("K" & i), ", ")
    If UBound(isplit) > 0 Then
        For j = LBound(isplit) To UBound(isplit)
            Rows(i).Copy
            newrow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
            Range("A" & newrow).PasteSpecial
            Application.CutCopyMode = False
            Range("I" & newrow) = isplit(j)
            Range("J" & newrow) = jsplit(j)
            Range("K" & newrow) = ksplit(j)
        Next j
    End If
Next i
Rows("2:" & urange).EntireRow.Delete xlUp
Application.ScreenUpdating = True
End Sub

 

[TabulaRasa]

My appologies. I didn't think about how long inserting rows takes (time increases exponentially with number of rows)

This method takes about 5 seconds on 600 rows.

Sub testingtestingtwo()
Dim isplit, jsplit, ksplit, urange As Long, newrow As Long, i As Long, j As Long
Application.ScreenUpdating = False


urange = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To urange
    isplit = Split(Range("I" & i), ", ")
    jsplit = Split(Range("J" & i), ", ")
    ksplit = Split(Range("K" & i), ", ")
    If UBound(isplit) > 0 Then
        For j = LBound(isplit) To UBound(isplit)
            Rows(i).Copy
            newrow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
            Range("A" & newrow).PasteSpecial
            Application.CutCopyMode = False
            Range("I" & newrow) = isplit(j)
            Range("J" & newrow) = jsplit(j)
            Range("K" & newrow) = ksplit(j)
        Next j
    End If
Next i
Rows("2:" & urange).EntireRow.Delete xlUp
Application.ScreenUpdating = True
End Sub

Ndsutherland,
I really appreciate you trying to help me iron this out! Unfortunately that code also produced an error (Run-time error '9': Subscript out of range), although it only took ~5-10 seconds to do so this time. Again, thank you for your help!

 

[ndsutherland]

What line is highlighted if hit debug?

 

[ndsutherland]

This should fix it

Sub testingtestingtwo()
Dim isplit, jsplit, ksplit, urange As Long, newrow As Long, i As Long, j As Long
Application.ScreenUpdating = False


urange = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To urange
    isplit = Split(Range("I" & i), ",")
    jsplit = Split(Range("J" & i), ",")
    ksplit = Split(Range("K" & i), ",")
        
    For j = LBound(isplit) To WorksheetFunction.Max(UBound(isplit), UBound(jsplit), UBound(ksplit))
        Rows(i).Copy
        newrow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
        Range("A" & newrow).PasteSpecial
        Application.CutCopyMode = False
        
        If UBound(isplit) < j Then Range("I" & newrow).ClearContents Else Range("I" & newrow) = Trim(isplit(j))
        If UBound(jsplit) < j Then Range("J" & newrow).ClearContents Else Range("J" & newrow) = Trim(jsplit(j))
        If UBound(ksplit) < j Then Range("K" & newrow).ClearContents Else Range("K" & newrow) = Trim(ksplit(j))
    Next j
Next i
Rows("2:" & urange).EntireRow.Delete xlUp
Application.ScreenUpdating = True


End Sub

I hope you are running this on a copy or sample of your original