Take the 2-minute tour ×
Super User is a question and answer site for computer enthusiasts and power users. It's 100% free, no registration required.

I am trying to create a macro to split a cell containing two or more line of characters. I would like to keep the others cells of the row.

For example

_____________
|     |   A |
|Row 1|   B |
|     |   C |
|___________|
|     |   D |
|     |   E |
|Row 2|   F |
|     |   G |
|_____|_____|

to

_____________
|Row 1 |   A |
|____________|
|Row 1 |   B |
|____________|
|Row 1 |   C |
|____________|
|Row 2 |   D |
|____________|
|Row 2 |   E |
|____________|
|Row 2 |   F |
|____________|
|Row 2 |   G |
|____________|

I would apreciate any help.

Edited on 12 oct.

Here the Jook's code with my modification :

Public Sub test()
  Dim arr() As Variant
  Dim arrSum() As Variant
  Dim arrResult() As Variant
  Dim arrTemp As Variant

  Dim i As Long
  Dim j As Long

  'input of array to seperate
  arr = Range("A1:J3500")

  ReDim Preserve arrSum(1 To 2, 1 To 1)

  'create the array with seperated A B C
  For i = LBound(arr, 1) To UBound(arr, 1)
    'use split to make A B C into an array, using 'enter' (chr(10)) as indicator
    arrTemp = Split(arr(i, 2), Chr(10))
    For j = LBound(arrTemp) To UBound(arrTemp)
      arrSum(1, UBound(arrSum, 2)) = arr(i, 1) 'set Row1
      arrSum(2, UBound(arrSum, 2)) = arrTemp(j)  'set A,B,C
      ReDim Preserve arrSum(1 To 2, _
                      LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
    Next j
  Next i

  'clean up last empty row (not realy necessary)
  ReDim Preserve arrSum(1 To 2, _
                        LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))

  'setup transposed result array
  ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
                  LBound(arrSum, 1) To UBound(arrSum, 1))

  'transpose the array
  For i = LBound(arrResult, 1) To UBound(arrResult, 1)
    For j = LBound(arrResult, 2) To UBound(arrResult, 2)
      arrResult(i, j) = arrSum(j, i)
    Next j
  Next i

  'specify target range
    Range(Cells(1, 12), Cells(UBound(arrResult, 1), 19 + UBound(arrResult, 2))) = arrResult


End Sub

I would like to add in each array 8 others cells.

Maybe it is easier to understand with a little schema :

_______________________________
|     |   A |        |        |
|Row 1|   B | Info_1 | Info_X |
|     |   C |        |        |
|___________|________|________|
|     |   D |        |        |
|     |   E |        |        |
|Row 2|   F | Info_2 | Info_Y |
|     |   G |        |        |
|_____|_____|________|________|

to

________________________________
|Row 1 |   A | Info_1 | Info_X |
|____________|________|________|
|Row 1 |   B | Info_1 | Info_X |
|____________|________|________|
|Row 1 |   C | Info_1 | Info_X |
|____________|________|________|
|Row 2 |   D | Info_2 | Info_Y |
|____________|________|________|
|Row 2 |   E | Info_2 | Info_Y |
|____________|________|________|
|Row 2 |   F | Info_2 | Info_Y |
|____________|________|________|
|Row 2 |   G | Info_2 | Info_Y |
|____________|________|________|

I was thinking about add this line

      arrSum(x, UBound(arrSum, x)) = arrTemp(j)  'with x as the number of the columns

But it's seems I have to modify another variable.

share|improve this question
    
my new version would cover 8 or more info columns, you would have just to adapt the target Range at the end to a suitable position. –  Jook Oct 12 '12 at 13:24
    
just as a correction UBound(arrSum, x) -> the x specifies the dimension! arrSum has only 2! arrSum(DIMENSION1, DIMENSION2). –  Jook Oct 12 '12 at 13:26

1 Answer 1

up vote 0 down vote accepted

Try the following code, it worked on your example and should give you a good start. The included comments should explain the functionality enough.

Public Sub solutionJook()
  Dim arr() As Variant
  Dim arrSum() As Variant
  Dim arrResult() As Variant
  Dim arrTemp As Variant

  Dim i As Long
  Dim j As Long

  'input of array to seperate
  arr = Range("A1:B2")

  ReDim Preserve arrSum(1 To 2, 1 To 1)

  'create the array with seperated A B C
  For i = LBound(arr, 1) To UBound(arr, 1)
    'use split to make A B C into an array, using 'enter' (chr(10)) as indicator
    arrTemp = Split(arr(i, 2), Chr(10))
    For j = LBound(arrTemp) To UBound(arrTemp)
      arrSum(1, UBound(arrSum, 2)) = arr(i, 1) 'set Row1
      arrSum(2, UBound(arrSum, 2)) = arrTemp(j)  'set A,B,C
      ReDim Preserve arrSum(1 To 2, _
                      LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
    Next j
  Next i

  'clean up last empty row (not realy necessary)
  ReDim Preserve arrSum(1 To 2, _
                        LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))

  'setup transposed result array
  ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
                  LBound(arrSum, 1) To UBound(arrSum, 1))

  'transpose the array
  For i = LBound(arrResult, 1) To UBound(arrResult, 1)
    For j = LBound(arrResult, 2) To UBound(arrResult, 2)
      arrResult(i, j) = arrSum(j, i)
    Next j
  Next i

  'specify target range
  Range(Cells(1, 5), Cells(UBound(arrResult, 1), 4 + UBound(arrResult, 2))) = arrResult

End Sub

As a remark: there surely is room for optimization

This is the magic line -> arrTemp = Split(arr(i, 2), Chr(10)) - thanks to Spilt you can easily transform your data into an array, using any character as a delimiter. All the other stuff is just surrounding to get to this array or to transform it into the desired result.

Edit: An updated Version, which adapts more dynamical to its input

Public Sub solutionJook()
  Dim arr() As Variant
  Dim arrSum() As Variant
  Dim arrResult() As Variant
  Dim arrTemp As Variant

  Dim i As Long
  Dim j As Long
  Dim h As Long
  Dim lngSplitColumn As Long
  'input of array to seperate
  arr = Range("A1:C2")
  'specify which column has the values to be split up
  lngSplitColumn = 2

  'using the boundries of the given range,
  'arrSum has now always the right boundries for the first dimension
  ReDim Preserve arrSum(LBound(arr, 2) To UBound(arr, 2), 1 To 1)

  'create the array with seperated A B C
  For i = LBound(arr, 1) To UBound(arr, 1)
    'use split to make A B C into an array, using 'enter' (chr(10)) as indicator
    arrTemp = Split(arr(i, lngSplitColumn), Chr(10))
    'every value of arrTemp creates a new row
    For j = LBound(arrTemp) To UBound(arrTemp)
      'loop through all input columns and create the new row
      For h = LBound(arr, 2) To UBound(arr, 2)
        If h = lngSplitColumn Then
          'setup the value of the splitted column
          arrSum(h, UBound(arrSum, 2)) = arrTemp(j)  'set A,B,C
        Else
          'setup the value of any other column
          arrSum(h, UBound(arrSum, 2)) = arr(i, h) 'set Value of Column h
        End If
      Next h

      ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
                            LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
    Next j
  Next i

  'clean up last empty row (not realy necessary)
  ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
                        LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))

  'setup transposed result array
  ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
                  LBound(arrSum, 1) To UBound(arrSum, 1))

  'transpose the array
  For i = LBound(arrResult, 1) To UBound(arrResult, 1)
    For j = LBound(arrResult, 2) To UBound(arrResult, 2)
      arrResult(i, j) = arrSum(j, i)
    Next j
  Next i

  'specify target range
  Range(Cells(1, 5), Cells(UBound(arrResult, 1), 4 + UBound(arrResult, 2))) = arrResult

End Sub
share|improve this answer
    
Thanks a lot for your code sample. It works perfectly with my example. My real spreadsheet have 10 colums and around 3500 rows, I will try to adapt your code. How could I write the result array in a new sheet ? –  J. Smith Oct 12 '12 at 10:42
    
Your welcome ;) and please accept/upvote if it solved your problem. To write the array in a new sheet, look at the line after 'specify target range -> TableXY.Range(... would be a fast, but static way to use another Worksheet. You can of course create your own Range variable and set it to any Range of any Worksheet you like. One could even try to make this a Worksheet-Function, but that would go a bit beyond the current question. –  Jook Oct 12 '12 at 10:48
    
Thanks again. Do you have an idea how could I add in the array more columns after the letters (A, B, C, D ...) ? –  J. Smith Oct 12 '12 at 12:41
    
I've tried to add this line after 'set A,B,C -> arrSum(3, UBound(arrSum, 3)) = arr(i, 3) –  J. Smith Oct 12 '12 at 12:45
    
@J.Smith check my update, and use the debugger to step through the code - you might understand the build-up and filling of the arrays better then. –  Jook Oct 12 '12 at 13:21

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.