英文:
How to split multiple columns with comma separated values into different rows while maintaining value sequence in the different columns?
问题
使用VBA，如何拆分一个包含共同数据的Excel表格，以及包含逗号分隔值的其余列。表格格式类似于下图所示：
预期结果类似于下图所示：
尝试使用Power Query，但静态数据在对每个逗号分隔列数据执行操作时会重复。
英文:
Using VBA, how to split an excel table containing few columns with common data and remaining columns containing comma separated values. The table format is something like
And the expected result is something like
Tried using Power Query but static data is repeated with actions done on each comma separated column data.
答案1
得分: 2
以下是您要翻译的内容：
这是Power Query 中的一种方式
"Added Custom" = Table.AddColumn(Source, "Custom", each Table.FromColumns({Text.Split([Column3],","),Text.Split([Column4],","),Text.Split([Column5],",")})),
"Removed Columns" = Table.RemoveColumns("Added Custom",{Column3, Column4, Column5}),
"Expanded Custom" = Table.ExpandTableColumn("Removed Columns", "Custom", {"Column1", "Column2", "Column3"}, {"Column3", "Column4", "Column5"})
in "Expanded Custom"```
[![enter image description here][1]][1]
<details>
<summary>英文:</summary>
This is one way in powerquery
let Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Added Custom" = Table.AddColumn(Source, "Custom", each Table.FromColumns({Text.Split([Column3],","),Text.Split([Column4],","),Text.Split([Column5],",")})),
#"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Column3", "Column4", "Column5"}),
#"Expanded Custom" = Table.ExpandTableColumn(#"Removed Columns", "Custom", {"Column1", "Column2", "Column3"}, {"Column3", "Column4", "Column5"})
in #"Expanded Custom"
[![enter image description here][1]][1]
[1]: https://i.stack.imgur.com/nFsVL.png
</details>
# 答案2
**得分**: 1
以下是您要翻译的内容：
该算法以以下方式作为输入：
1）ListObject对象，
2）要放置新表格的单元格，
3）分隔符字符串以及
4）我们要将其内容拆分为多行的列的索引。
表格可以有任意多列，并且还有一件事：我们要分割的单元格不必具有相同数量的元素，例如column2 a，b，c column3 a，b，c，d
接下来是另一个函数，它执行完全相反的操作。它将新扩展的表格转换为原始表格的形式，还有一个选项，可以选择在由连接生成的列中不包含（内部）重复值。尽管它不回答这个问题，但我在这里发布它，因为它与答案相关，它是答案结果的“撤消”。
这是一段VBA代码，用于扩展和缩小表格。如果您需要任何其他信息，请随时提问。
<details>
<summary>英文:</summary>
The algorithm takes as input 1) a ListObject object, 2) a cell where to place the new table 3) the separator string and 4) the index of the columns whose content we want to break into multiple lines. The table can have as many columns as need and one more thing: The cells we want to partition do not have to have the same number of elements, for example column2 a,b,c column3 a,b,c,d
Then follows another Function which does the exact opposite. It takes the new expanded table and converts it to the form of the original one, also having an option not to have (internal) duplicate values in the columns made by concatenation. Although it doesn't answer the question, I'm posting it here because it's interrelated with the answer, it's an "undo" of the result of the answer.
Option Explicit
'this EVENT in a sheet module, call the sub with the parameters
Private Sub BT_EXPAND_Click()
Dim expTbl As ListObject
Const separator = ","
Set expTbl = expand_table(Me.ListObjects("TABLEA"), Me.Range("A8"), separator, 3, 4, 5)
If Not expTbl Is Nothing Then
Call shrink_table(expTbl, Me.Range("A" & (expTbl.ListRows.Count + 11)), False, separator, 3, 4, 5)
End If
End Sub
'****************************************************************************
'* COPY THIS PUBLIC FUNCTION IN A MODULE
'* CAN USE IT FOR ANY TABLE WITH ANY ROWS/COLUMNS
'* ----------------PARAMETERS--------------------
'* ListObject> the table object to expand its data
'* topLeftOfNewTable> the cell to fit the top-left corner of the new table
'* separator> separator string of concatenated values at columns we tranform
'* colsWithComma> ParamArray with indexes of columns to transform eg 3,5,6,7
'****************************************************************************
Public Function expand_table(ByRef t As ListObject, topLeftOfNewTable As Range, separator As String, _
ParamArray colsWithComma() As Variant) As ListObject
Dim rws As Long, clmns As Long, r As Long, c As Long, tex As ListObject, clarr() As Variant, strFlag As String
Dim lbWc As Integer, ubWc As Integer, z As Integer, zidx As Integer, tmpUb As Integer, maxExp As Integer, lrw As ListRow
Dim ccex As Integer
lbWc = LBound(colsWithComma)
ubWc = UBound(colsWithComma)
If ubWc < 0 Then Exit Function 'nothing todo
On Error GoTo Lerr
rws = t.DataBodyRange.Rows.CountLarge
clmns = t.DataBodyRange.Columns.CountLarge
'CREATE A STRING WITH AS MANY SPACES AS THE COLUMNS OF TABLE
'AT POSITIONS OF colsWithComma() SET "*" (FLAG THE POSITION COLUMNS TO EXPAND)
strFlag = Space$(clmns)
For z = lbWc To ubWc
If colsWithComma(z) <= clmns Then
Mid$(strFlag, colsWithComma(z), 1) = "*"
Else
MsgBox ("expand_table> Column " & colsWithComma(z) & " out of table bounds - max=" & clmns)
End If
Next
Application.ScreenUpdating = False
'IF ALREADY EXISTS A TABLE IN THE POSTOTION OF THE NEW, DELETE IT
If Not topLeftOfNewTable.ListObject Is Nothing Then
topLeftOfNewTable.ListObject.Delete
End If
'CREATE NEW TABLE TO EXPORT THE ORIGINAL
Set tex = topLeftOfNewTable.Worksheet.ListObjects.Add(xlSrcRange, topLeftOfNewTable.Resize(1, t.DataBodyRange.Columns.Count), , xlYes)
'COPY THE HEADER LINE
t.HeaderRowRange.Copy topLeftOfNewTable
'redim the array to hold the arrays of columns values, when split them
ReDim clarr(lbWc To ubWc)
For r = 1 To rws
' in every row find the column with the maximum elements after split
maxExp = 0
For z = lbWc To ubWc
clarr(z) = Split(t.ListRows(r).Range.Cells(, colsWithComma(z)), separator)
tmpUb = UBound(clarr(z))
If tmpUb > maxExp Then maxExp = tmpUb
Next
'WE LOOP FROM 0 TO maximum found above
For ccex = 0 To maxExp
zidx = 0
Set lrw = tex.ListRows.Add
For c = 1 To clmns
With lrw.Range.Cells(, c)
'IF THE COLUMN HAVE TO SPLIT
If Mid$(strFlag, c, 1) <> " " Then
tmpUb = UBound(clarr(zidx))
'IF THE ARRAY OF SPLITED VALUES EXIST AND INDEX (ccex) <= UPPER BOUND
If tmpUb >= 0 And ccex <= tmpUb Then
'COPY THE VALUE FROM ARRAY (splitted data)
.Value2 = clarr(zidx)(ccex)
End If
'NEXT SPLITING COLUMN
zidx = zidx + 1
Else
'COPY THE ORIGINAL VALUE AS IS
.Value2 = t.ListRows(r).Range.Cells(, c)
End If
End With
Next
Next
Next
Set expand_table = tex
Exit Function
Lerr:
If Err.Number > 0 Then
MsgBox ("expand_table>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
End If
On Error GoTo 0
End Function
'*****************************************************************************
'* COPY THIS PUBLIC FUNCTION IN A MODULE
'* This function reverse the result of the previus, creates the original
'* table from the expanded one, having the option not to have duplicate values
'* in the columns made by concatenation
'* ----------------PARAMETERS--------------------
'* ListObject> the table object to expand its data
'* topLeftOfNewTable> the cell to fit the top-left corner of the new table
'* separator> separator string to concatenate values at columns we tranform
'* colsToConcat> ParamArray with indexes of columns to be tranformed eg 3,5,6,7
'*****************************************************************************
Public Function shrink_table(ByRef t As ListObject, topLeftOfNewTable As Range, _
allowDuplicatesInConcat As Boolean, separator As String, ParamArray colsToConcat() As Variant) As ListObject
Dim rws As Long, clmns As Long, r As Long, c As Long, tex As ListObject, strFlag As String
Dim lbWc As Integer, ubWc As Integer, lrw As ListRow, stmp As Variant
lbWc = LBound(colsToConcat)
ubWc = UBound(colsToConcat)
If ubWc < 0 Then Exit Function 'nothing todo
On Error GoTo Lerr
rws = t.DataBodyRange.Rows.CountLarge
clmns = t.DataBodyRange.Columns.CountLarge
'CREATE A STRING WITH AS SPACES AS THE COLUMNS OF TABLE
'AT POSITIONS OF colsToConcat() SET "*" (FLAG THE POSITION COLUMNS TO CONCAT)
strFlag = Space$(clmns)
For c = lbWc To ubWc
If colsToConcat(c) <= clmns Then
Mid$(strFlag, colsToConcat(c), 1) = "*"
Else
MsgBox ("shrink_table> Column " & colsToConcat(c) & " out of table bounds - max=" & clmns)
Exit Function
End If
Next
Application.ScreenUpdating = False
'IF ALREADY EXISTS A TABLE IN THE POSTOTION OF THE NEW, DELETE IT
If Not topLeftOfNewTable.ListObject Is Nothing Then
topLeftOfNewTable.ListObject.Delete
End If
'COPY THE TABLE
't.Range.Copy topLeftOfNewTable
Set tex = topLeftOfNewTable.Worksheet.ListObjects.Add(xlSrcRange, topLeftOfNewTable.Resize(1, t.DataBodyRange.Columns.Count), , xlYes)
'tex.Name = "TABLEA_CONCAT"
t.HeaderRowRange.Copy topLeftOfNewTable
Set lrw = tex.ListRows.Add
t.ListRows(1).Range.Copy lrw.Range
For r = 2 To rws
'Set lrw = tex.ListRows.Add
For c = 1 To clmns
'With lrw.Range.Cells(, c)
If Mid$(strFlag, c, 1) = " " Then
If t.ListRows(r).Range.Cells(, c) <> lrw.Range.Cells(, c) Then
Set lrw = tex.ListRows.Add
t.ListRows(r).Range.Copy lrw.Range
GoTo LnextRow
End If
End If
'End With
Next
For c = 1 To clmns
If Mid$(strFlag, c, 1) = " " Then
'copy value
lrw.Range.Cells(, c) = t.ListRows(r).Range.Cells(1, c)
Else
'add value
With lrw.Range.Cells(, c)
stmp = t.ListRows(r).Range.Cells(1, c)
If stmp <> vbNullString Then
If allowDuplicatesInConcat Then
.value = .value & separator & stmp
Else
If InStr(1, separator & .value & separator, separator & stmp & separator) <= 0 Then
.value = .value & separator & stmp
End If
End If
End If
End With
End If
Next
LnextRow:
Next
Set shrink_table = tex
Exit Function
Lerr:
If Err.Number > 0 Then
MsgBox ("shrink_table>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
End If
On Error GoTo 0
End Function
[![enter image description here][1]][1]
[1]: https://i.stack.imgur.com/WeA0s.png
</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论