将具有多行的单元格拆分为行并使用 vba 更改分组

Question

我想在“。”之后将单元格拆分为 TextA、TextB 和 TextC。 并按文本类型排序。

我也试过这个：

Sub split_By_Text()

Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)


lrow1 = sh1.Range("A65356").End(xlUp).Row


For j = 2 To lrow1

splitVals = Split(sh1.Cells(j, 2), ".")

totalVals = UBound(splitVals)

For i = LBound(splitVals) To UBound(splitVals)
    lrow2 = sh2.Range("B65356").End(xlUp).Row
    lrow3 = sh2.Range("A65356").End(xlUp).Row
    sh2.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)
    'Debug.Print sh1.Cells(j, 1)
    sh2.Cells(lrow2 + 1, 2) = splitVals(i)
    'Debug.Print splitVals(i)
Next i

Next j

sh2.Activate




sh2.Range("A1") = "Drink ID"
sh2.Range("B1") = "Recipe_data"
sh2.Range("C1") = "Volume"



End Sub

但是当我只有一句话 excel 也加一行。

谢谢

输入：

Output：

Answer 1

根据流派重新排列要拆分的数据

演示通过数组分配和使用Application.Index() function的高级重组功能的方法：

Sub ReArrange()
Const GENRE& = 1, ID& = 2, TXT& = 5, TXTA& = 6, TXTB& = 7, TXTC& = 8                     ' columns in variant array v2
With Sheet1                                   ' source sheet's CodeName (!)
  ' [0] define data range
    Dim v, rng As Range, lastRow&
    lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set rng = .Range("A1:F" & lastRow)
  ' [1] get data
    v = rng
  ' [2] rearrange array rows & columns (inserting 2 new columns)
    v = Application.Index(v, _
         Application.Transpose(getRows(v)), _
         Array(0, 1, 2, 3, 0, 4, 5, 6))
    v(1, GENRE) = "Genre": v(1, TXT) = "Text"    ' renew headers
  ' [3] Fill in genre & tokens
    Dim i&, ii&, cnt&                             ' item counters
    Dim a&, b&, c&                                ' split item boundaries

    For i = 2 To UBound(v)                        ' loop through v2
        If v(i, ID) <> v(i - 1, ID) Then
            cnt = 0: ii = 0
            a = UBound(Split(v(i, TXTA), "."))    ' items TextA
            b = UBound(Split(v(i, TXTB), "."))    ' items TextB
            c = UBound(Split(v(i, TXTC), "."))    ' items TextC
        End If
        cnt = cnt + 1: ii = ii + 1                ' increment id and genre counters
        Select Case cnt
            Case Is <= a: v(i, GENRE) = "A"
                v(i, GENRE) = "A": v(i, TXT) = Split(v(i, TXTA), ".")(ii - 1): If ii = a Then ii = 0
            Case Is <= a + b
                v(i, GENRE) = "B": v(i, TXT) = Split(v(i, TXTB), ".")(ii - 1): If ii = b Then ii = 0
            Case Is <= a + b + c
                v(i, GENRE) = "C":  v(i, TXT) = Split(v(i, TXTC), ".")(ii - 1): If ii = c Then ii = 0
        End Select

    Next i
End With

  ' [4] write results back whereever you want (reducing array by 3 temporary columns)
    Sheet2.Range("A1").Resize(UBound(v), UBound(v, 2) - 3) = v

End Sub

助手 function getRows()

Function getRows(arr) As Variant()
' Purpose: return an array of n-times repeated row numbers (based on number of splits)
Dim i&, ii&, j&, cnt&
Dim tmp(), tokens
ReDim tmp(0 To UBound(arr) * 10)
tmp(cnt) = 1: cnt = cnt + 1        ' one title row equals row no 1; increment new rows counter
For i = 2 To UBound(arr)
    For j = 4 To 6                  ' D:F
        tokens = Split(arr(i, j), ".")  ' upper boundary minus one because of right side point
        For ii = LBound(tokens) To UBound(tokens) - 1
            tmp(cnt) = i            ' input row number as often as necessary
            cnt = cnt + 1           ' increment counter
        Next ii
    Next
Next i
ReDim Preserve tmp(0 To cnt - 1)    ' resize array to actual item size
getRows = tmp                       ' return function result array
'Debug.Print Join(tmp, ",")         ' Array(1,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,5,5,5,5,5,5,6,6,6,6,6,6)
End Function