2

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.

2
  • 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, 2012 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, 2012 at 13:26

1 Answer 1

0

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
6
  • 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, 2012 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, 2012 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, 2012 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, 2012 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, 2012 at 13:21

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .