excel - 将具有多行的单元格拆分为行并使用 vba 更改分组
问题描述
我想在“。”之后将单元格拆分为 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也加一行。
谢谢
输入:
输出:
解决方案
根据流派重新排列要拆分的数据
Application.Index()
通过数组分配和使用函数的高级重组功能演示一种方法:
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
辅助函数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
推荐阅读
- odoo - Odoo 13 TypeError:strptime() 参数 1 必须是 str,而不是 datetime.dateE
- javascript - 动态创建的表中的行单击事件返回未定义的错误?
- javascript - css禁用按钮在平板电脑中不起作用
- mysql - vb.net 索引所选单元格的行
- c# - 具有自有类型 SQL Server 的脚手架 dbcontext
- laravel - 找不到 SoapClient 类
- python-3.x - 我想根据熊猫的现金价值找到前 3 名的客户
- bash - 如何停止 vsftpd 服务器
- regex - Ruby 路由 URI 正则表达式
- javascript - D365/JavaScript 问题:需要帮助附加 OnSave 事件以不允许用户保存表单