尝试为每一行创建所有唯一值组合,因为每个单元格可能有也可能没有多个嵌套值。目标是解释每一行并为每个唯一的值组合写一个新行。
Sub combo(x As Integer, splitCell As Boolean, lastcol As Long)
Dim cellArray() As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Test")
For y = lastcol To 2 Step -1
Dim counter As Integer
counter = 0
cellValue = ws.Cells(x, y).Value
cellArray() = Split(cellValue, Chr(10))
Debug.Print cellValue
If UBound(cellArray()) > LBound(cellArray()) Then
Debug.Print "Splitting " & x, y
For t = UBound(cellArray()) To LBound(cellArray()) Step -1
Rows(x + counter).Offset(1).EntireRow.Insert
counter = counter + 1
For a = lastcol To 1 Step -1
If a = y Then
ws.Cells(x + counter, a).Value = cellArray(t)
splitCell = True
rowToDel = x
Else
ws.Cells(x + counter, a).Value = ws.Cells(x, a).Value
splitCell = True
End If
Next a
Next t
End If
x = x + counter
Next y
If splitCell = True Then
Rows(rowToDel).EntireRow.Delete
End If
x = x - 1
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
End Sub
此代码目前适用于具有嵌套值的一个单元格与该行中其他单元格中的单个条目的情况。但是,最多可以有三列,每列都有嵌套值,应该为其创建唯一条目。
答案 0 :(得分:1)
在下面的评论中,我假装您要拆分的数据是逗号分隔的。我这样做只是因为使用逗号显示示例比使用制表符更容易。包含的代码仍然使用制表符作为分隔符。
如果我正确理解你的问题,当你有一个值(例如)" 1,4,67"在Q列中,您的代码正确地生成了额外的行 - 一个用" 1"在Q栏中,一个用" 4"在Q栏中,一个用" 67"在Q列中,从原始行复制所有其他列。
但是,当你有第二个包含多个逗号分隔值的单元格时,请说" A,B"在T栏中," A,B"仍然出现在前两个生成的行中的每一行上,并且仅在第三行上分割 - 因此总共创建了4行。但是你想要生成六行(每个值为#34; A,B和#34;每个值为" 1,4,67和#34;)。
我还假设您正在为原始数据中的每一行调用子例程。
以下代码将处理一行,展开每个值,以便获得每个组合:
Sub combo(x As Integer, splitCell As Boolean, lastcol As Long)
Dim cellArray() As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim t As Long
Dim y As Long
Dim a As Long
Dim cellValue
Dim dstRow As Integer
Dim srcRow As Integer
Dim aCellWasSplit As Boolean
srcRow = x
dstRow = x
splitCell = False
Do While srcRow <= dstRow
aCellWasSplit = False
For y = lastcol To 2 Step -1
cellValue = ws.Cells(x, y).Value
cellArray() = Split(cellValue, Chr(10))
Debug.Print cellValue
If UBound(cellArray()) > LBound(cellArray()) Then
Debug.Print "Splitting " & x, y
aCellWasSplit = True
For t = UBound(cellArray()) To LBound(cellArray()) Step -1
dstRow = dstRow + 1
Rows(dstRow).EntireRow.Insert
For a = lastcol To 1 Step -1
If a = y Then
ws.Cells(dstRow, a).Value = cellArray(t)
Else
ws.Cells(dstRow, a).Value = ws.Cells(srcRow, a).Value
End If
Next a
Next t
Exit For
End If
Next y
If aCellWasSplit Then
ws.Rows(srcRow).EntireRow.Delete
dstRow = dstRow - 1
splitCell = True
Else
srcRow = srcRow + 1
End If
Loop
x = dstRow + 1
End Sub
以下代码可用于测试它:
Sub test()
Dim anythingProcessed As Boolean
Dim currentRow As Integer
Dim lastCol As Long
currentRow = 1
lastCol = 5
Do While currentRow <= ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
combo currentRow, anythingProcessed, lastCol
Loop
End Sub