VBA To Split adjacent Cells into Rows

[kparadise]

Hello. Very new to VBA (very new). I have a spreadsheet with three columns and need to do some work in the last two columns.

[Sheet 1].[Column A] - ID
[Sheet 1].[Column B] - BUILDING
[Sheet 1].[Column C] - DESC

ID	BUILDING	DESC
A	L1 L2	Very Large Extended
B	L1 L3 L4	Extra Large Tiny Long
C	S1	Small
D	F3 F4	Fort Fortable

<tbody>
</tbody>

Columns B and C can contain multiple 'records' of data which are separated in the same cell by a return sign. For example, ID = A, the text "L1" and "L2" are separated by a paragraph symbol. The same goes for the text in Column C. "Very Large" and "Extended" are separated by a return symbol. The catch he is, the way this system reporting was designed, L1 is connected with Very Large, and L2 is connected with Extended, and L3 is connected with Tiny. So, basically the data which is connected to each other is the same just separated by a paragraph sign.

What I am trying to get VBA for, is to insert as many rows as need to split up the data in columns B and C; and then copy down the ID into the rows below it as well.

ANSWER:

ID	BUILDING	DESC
A	L1	Very Large
A	L2	Extended
B	L1	Extra Large
B	L3	Tiny
B	L4	Long
C	S1	Small
D	F3	Fort
D	F4	Fortable

<tbody>
</tbody>

 

[mumps]

Try:

Sub SplitData()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    Dim BuildRng As Variant
    Dim DescRng As Variant
    Dim i As Long
    For x = LastRow To 2 Step -1
        BuildRng = Split(Cells(x, 2), Chr(10))
        DescRng = Split(Cells(x, 3), Chr(10))
        For i = UBound(BuildRng) To 0 Step -1
            Rows(x + 1).Insert
            Cells(x + 1, 2) = BuildRng(i)
            Cells(x + 1, 3) = DescRng(i)
            Cells(x + 1, 1) = Cells(x, 1)
        Next i
        Rows(x).EntireRow.Delete
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

This macro should be faster (noticeably so if you have a large number of rows of data)...

[table="width: 500"]
[tr]
	[td]Sub ID_Building_Desc()
  Dim R As Long, X As Long, Z As Long, LastRow As Long, MaxNewRows As Long, ID As String
  Dim Data As Variant, Result As Variant, Bldg As Variant, Desc As Variant
  LastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Data = Range("A2:C" & LastRow)
  MaxNewRows = UBound(Data) + Evaluate(Replace("SUM(LEN(B2:B#)-LEN(SUBSTITUTE(B2:B#,CHAR(10),"""")))", "#", LastRow))
  ReDim Result(1 To MaxNewRows, 1 To 3)
  For R = 1 To UBound(Data)
    If Len(Data(R, 1)) > 0 And Data(R, 1) <> ID Then ID = Data(R, 1)
    Bldg = Split(Data(R, 2), vbLf)
    Desc = Split(Data(R, 3), vbLf)
    For Z = 0 To UBound(Bldg)
      X = X + 1
      Result(X, 1) = ID
      Result(X, 2) = Bldg(Z)
      Result(X, 3) = Desc(Z)
    Next
  Next
  Range("A2").Resize(UBound(Result), 3) = Result
End Sub[/td]
[/tr]
[/table]

 

[kparadise]

Hello,

Thank you both. MrExcel MVP I did use your code because I am going to be dealing with ALOT of data.

Quick question; The column names within my post are fake. If I use this code, do I need to rename the column headers in my spreadsheet? Or, is there a way to change the code to deal with this issue regardless of what Columns A - C are?

 

[Rick Rothstein]

Thank you both. MrExcel MVP I did use your code because I am going to be dealing with ALOT of data.

You could have referred to me by my name Rick or, if you wanted to be more formal, Mr. Rothstein... MrExcel MVP is an honorary title that a lot of the volunteers at this forum have been awarded.

...I am going to be dealing with ALOT of data.

How much is a lot of data? I just noticed that one of the code lines I used has a 65,535 row limitation to it. If you have more data than that, let me know and I'll adjust that code line to avoid this row count limitation (it will slow the code down a little, but the overall macro will still be quite fast).

Quick question; The column names within my post are fake. If I use this code, do I need to rename the column headers in my spreadsheet? Or, is there a way to change the code to deal with this issue regardless of what Columns A - C are?

The column headers do not matter as my code starts looking for data at Row 2 and never looks at what is in Row 1.

 

[kparadise]

Ummm, I just ran a length function on "COLUMN C" and the highest values are around...5000 characters.

I am really not sure, b/c this document can change drastically. However, it will never exceed the 1.04million rows in a normal tab. I want to say 250,000 would be the absolute max number of rows it would ever 'grow' to after running that code.

 

[kparadise]

So, I am getting a error below:

___________________
Run-time error '9':
Subscript out of range
___________________

I have no idea what is happening, I tried it yesterday with dummy data and it worked. Now i tried it on the real file and I am getting this error.

 

[kparadise]

OK, so I figured out the code is running into this error in Column C.

I do believe this is a length issue. How would you change the code to not put a limit on it?

 

[Rick Rothstein]

I do believe this is a length issue.

I believe it is the number of rows that is doing my code in. One line of code uses the Evaluate function to speed things up; however, that function has a 65,535 row limitation. This code should fix the problem and still be speedy enough...

[table="width: 500"]
[tr]
	[td]Sub ID_Building_Desc()
  Dim R As Long, X As Long, Z As Long, LastRow As Long, MaxNewRows As Long, ID As String
  Dim Data As Variant, Result As Variant, Bldg As Variant, Desc As Variant
  LastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Data = Range("A2:C" & LastRow).Value
  For R = 1 To UBound(Data)
    MaxNewRows = MaxNewRows + Len(Data(R, 2)) - Len(Replace(Data(R, 2), vbLf, "")) + 1
  Next
  ReDim Result(1 To MaxNewRows, 1 To 3)
  For R = 1 To UBound(Data)
    If Len(Data(R, 1)) > 0 And Data(R, 1) <> ID Then ID = Data(R, 1)
    Bldg = Split(Data(R, 2), vbLf)
    Desc = Split(Data(R, 3), vbLf)
    For Z = 0 To UBound(Bldg)
      X = X + 1
      Result(X, 1) = ID
      Result(X, 2) = Bldg(Z)
      Result(X, 3) = Desc(Z)
    Next
  Next
  Range("A2").Resize(UBound(Result), 3) = Result
End Sub[/td]
[/tr]
[/table]

 

[kparadise]

Still getting the run time error.

Dangit, I have no idea; I am a complete newb to VBA. The code works absolutely great when I only perform it on like 25 rows of the original data. But when I try to run it on all the rows (around 2,000) it throws error.