Как разбить ячейку подряд с помощью Excel

Question

Я пытаюсь создать макрос, чтобы разделить ячейку, содержащую две или более строки символов. Я хотел бы сохранить другие клетки подряд.

Например

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

в

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

Я был бы признателен за любую помощь.

Отредактировано 12 окт.

Вот код Jook с моей модификацией:

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

Я хотел бы добавить в каждом массиве 8 других ячеек.

Может быть, это легче понять с помощью небольшой схемы:

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

в

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

Я думал о добавлении этой строки

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

Но, похоже, мне нужно изменить другую переменную.

score 0 · Accepted Answer · 2011-03-09T19:38:42

Попробуйте следующий код, он работает на вашем примере и должен дать вам хорошее начало. Включенные комментарии должны достаточно объяснить функциональность.

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

В качестве замечания: безусловно, есть место для оптимизации

Это волшебная строка -> arrTemp = Split(arr(i, 2), Chr(10)) - благодаря Spilled вы можете легко преобразовать ваши данные в массив, используя любой символ в качестве разделителя. Все остальные вещи просто окружающие, чтобы добраться до этого массива или преобразовать его в желаемый результат.

Редактировать: обновленная версия, которая адаптируется более динамично к своему вводу

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

Сейчас выбран русский

Как разбить ячейку подряд с помощью Excel

1 ответ1

Всё ещё ищете ответ? Посмотрите другие вопросы с метками microsoft-excel macros.

Как разбить ячейку подряд с помощью Excel

1 ответ1

Всё ещё ищете ответ? Посмотрите другие вопросы с метками microsoft-excel macros.

Похожие