如何使用 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 |
|____________|

我将非常感激任何帮助。

10 月 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

但似乎我必须修改另一个变量。

Answer 1

尝试以下代码，它适用于您的示例，应该能为您提供良好的开端。所包含的注释应该足以解释该功能。

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))- 借助 Spilt，您可以轻松地将数据转换为数组，使用任何字符作为分隔符。所有其他东西都只是围绕着这个数组或将其转换为所需的结果。

编辑：更新版本，使其更动态地适应其输入

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