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

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="align: center"]ID
[/TD]
[TD="align: center"]BUILDING
[/TD]
[TD="align: center"]DESC
[/TD]
[/TR]
[TR]
[TD]A
[/TD]
[TD]L1
L2
[/TD]
[TD]Very Large
Extended
[/TD]
[/TR]
[TR]
[TD]B
[/TD]
[TD]L1
L3
L4
[/TD]
[TD]Extra Large
Tiny
Long
[/TD]
[/TR]
[TR]
[TD]C
[/TD]
[TD]S1
[/TD]
[TD]Small
[/TD]
[/TR]
[TR]
[TD]D
[/TD]
[TD]F3
F4
[/TD]
[TD]Fort
Fortable
[/TD]
[/TR]
</tbody>[/TABLE]

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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="align: center"]ID
[/TD]
[TD="align: center"]BUILDING
[/TD]
[TD="align: center"]DESC
[/TD]
[/TR]
[TR]
[TD]A
[/TD]
[TD]L1
[/TD]
[TD]Very Large
[/TD]
[/TR]
[TR]
[TD]A
[/TD]
[TD]L2
[/TD]
[TD]Extended
[/TD]
[/TR]
[TR]
[TD]B
[/TD]
[TD]L1
[/TD]
[TD]Extra Large
[/TD]
[/TR]
[TR]
[TD]B
[/TD]
[TD]L3
[/TD]
[TD]Tiny
[/TD]
[/TR]
[TR]
[TD]B
[/TD]
[TD]L4
[/TD]
[TD]Long
[/TD]
[/TR]
[TR]
[TD]C
[/TD]
[TD]S1
[/TD]
[TD]Small
[/TD]
[/TR]
[TR]
[TD]D
[/TD]
[TD]F3
[/TD]
[TD]Fort
[/TD]
[/TR]
[TR]
[TD]D
[/TD]
[TD]F4
[/TD]
[TD]Fortable
[/TD]
[/TR]
</tbody>[/TABLE]

 

[kparadise]

Rick,

I would really appreciate if you were able to assist in the code. I am stuck right now, and cannot do this manually - or I might throw my computer out the window.

 

[Rick Rothstein]

Still getting the run time error.

Is that error the same as you reported in Message #7 (error number 9, subscript out of range)? If not, what is the number and description?

What line of code is the error occurring on (that is, which line is highlighted in yellow when the code errors out)?

 

[kparadise]

It is the same error:

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

After I click the run button, there is no highlighted line in the code as this error occurs.

 

[Rick Rothstein]

It is the same error:

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

After I click the run button, there is no highlighted line in the code as this error occurs.

Does the error message box have a button labeled "Debug"? If so, click it... is one of the code lines highlighted now? If so, which one?

 

[kparadise]

Just a "OK" and a "HELP".

 

[Rick Rothstein]

Just a "OK" and a "HELP".

Can you post a copy of your workbook to DropBox so that the volunteers here can download it and test/debug our code out directly against your actual data? If you have sensitive information (names, addresses, phone numbers, email addresses, SS numbers, etc.), don't forget to replace them with junk text.

 

[kparadise]

I am not sure I can send this. There is too much PI on it.

I just ran it on 500 rows and it worked, but it did not work on 700 rows. Does that help at all?

 

[Rick Rothstein]

I am not sure I can send this. There is too much PI on it.

So are you saying the data that needs to be processed does not look at all like the example data you posted in Message #1 ? Is there private information on the sheet with the data that is being processed? If not, can you make a copy of your workbook and delete the worksheets that contain the private information... after doing that, does the code still work for 500 rows of data but not 700 rows of data? If so, then post the your original data with those worksheets deleted to DropBox for us. We only need the data that does not work (as long as it would work when the number of rows would be reduced).

I just ran it on 500 rows and it worked, but it did not work on 700 rows. Does that help at all?

No, without knowing what is in your cells and being able to see what the code is trying to do with those value live, I would have no idea where to start. There is something about your actual data that I seem unable to duplicate here.

 

[kparadise]

I think I might have figured it out!

So I found one row where Column B had three items; the but corresponding Column C only had 2 items. So, the last item in Column B would have a 'blank' in Column C after the de runs.

What I did was delete that row, and the code worked on the entire population. Is there a way to adjust the code to just put a blank in Column C instead of having to delete that record?

 

[Rick Rothstein]

I think I might have figured it out!

So I found one row where Column B had three items; the but corresponding Column C only had 2 items.

Yes, that would produce the error you were getting.

What I did was delete that row, and the code worked on the entire population. Is there a way to adjust the code to just put a blank in Column C instead of having to delete that record?

Give this revised code a try (it will tolerate missing information in either Column B or C). Note that is marks any blank cells in red so that you can see where there was a misalignment of data between the cell in Column B and the cell in Column C. If you do not want that functionality, simply remove the last line of code (above the End Sub statement).

[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
  Dim MaxCol2 As Long, MaxCol3 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)
    MaxCol2 = Len(Data(R, 2)) - Len(Replace(Data(R, 2), vbLf, ""))
    MaxCol3 = Len(Data(R, 3)) - Len(Replace(Data(R, 3), vbLf, ""))
    MaxNewRows = MaxNewRows + Application.Max(MaxCol2, MaxCol3) + 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)
    If UBound(Bldg) > UBound(Desc) Then
      ReDim Preserve Desc(0 To UBound(Bldg))
    ElseIf UBound(Bldg) < UBound(Desc) Then
      ReDim Preserve Bldg(0 To UBound(Desc))
    End If
    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
  Range("B2:C" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlBlanks).Interior.Color = vbRed
End Sub[/td]
[/tr]
[/table]