Cómo dividir una celda en una fila con Excel

2

Estoy tratando de crear una macro para dividir una celda que contiene dos o más líneas de caracteres. Me gustaría mantener las otras celdas de la fila.

Por ejemplo

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

a

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

Agradecería cualquier ayuda.

Editado el 12 oct.

Aquí el código de Jook con mi modificación:

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

Me gustaría agregar en cada matriz otras 8 celdas.

Quizás sea más fácil de entender con un pequeño esquema:

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

a

________________________________
|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 |
|____________|________|________|

Estaba pensando en agregar esta línea

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

Pero parece que tengo que modificar otra variable.

microsoft-excel macros J. Smith
fuente
mi nueva versión cubriría 8 o más columnas de información, solo tendría que adaptar el rango objetivo al final a una posición adecuada.
Jook
solo como una corrección UBound(arrSum, x)-> xespecifica la dimensión! arrSumtiene solo 2! arrSum(DIMENSION1, DIMENSION2).
Jook

Respuestas:

0

Pruebe el siguiente código, funcionó en su ejemplo y debería darle un buen comienzo. Los comentarios incluidos deben explicar la funcionalidad lo suficiente.

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

Como comentario: seguramente hay espacio para la optimización

Esta es la línea mágica -> arrTemp = Split(arr(i, 2), Chr(10))- gracias a Spilled puede transformar fácilmente sus datos en una matriz, utilizando cualquier carácter como delimitador. Todas las demás cosas solo están rodeando para llegar a esta matriz o para transformarla en el resultado deseado.

Editar: una versión actualizada, que se adapta más dinámicamente a su entrada

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
Jook
fuente
Muchas gracias por su código de muestra. Funciona perfectamente con mi ejemplo. Mi hoja de cálculo real tiene 10 columnas y alrededor de 3500 filas, intentaré adaptar su código. ¿Cómo podría escribir la matriz de resultados en una nueva hoja?
J. Smith
De nada;) y acepte / vote si resolvió su problema. Para escribir la matriz en una nueva hoja, mire la línea después de 'especificar rango objetivo -> TableXY.Range(...sería una forma rápida, pero estática de usar otra hoja de trabajo. Por supuesto, puede crear su propia variable de rango y establecerla en cualquier rango de cualquier hoja de trabajo que desee. Incluso se podría tratar de hacer de esto una Función de hoja de trabajo, pero eso iría un poco más allá de la pregunta actual.
Jook
Gracias de nuevo. ¿Tiene una idea de cómo podría agregar en la matriz más columnas después de las letras (A, B, C, D ...)?
J. Smith
Intenté agregar esta línea después del 'set A, B, C ->arrSum(3, UBound(arrSum, 3)) = arr(i, 3)
J. Smith el
@ J.Smith revisa mi actualización y usa el depurador para recorrer el código; entonces podrías entender mejor la acumulación y el llenado de los arreglos.
Jook