英文:
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 powerquerylet 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,dThen 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 parametersPrivate Sub BT_EXPAND_Click()Dim expTbl As ListObjectConst separator = ","Set expTbl = expand_table(Me.ListObjects("TABLEA"), Me.Range("A8"), separator, 3, 4, 5)If Not expTbl Is Nothing ThenCall shrink_table(expTbl, Me.Range("A" & (expTbl.ListRows.Count + 11)), False, separator, 3, 4, 5)End IfEnd 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 ListObjectDim rws As Long, clmns As Long, r As Long, c As Long, tex As ListObject, clarr() As Variant, strFlag As StringDim lbWc As Integer, ubWc As Integer, z As Integer, zidx As Integer, tmpUb As Integer, maxExp As Integer, lrw As ListRowDim ccex As IntegerlbWc = LBound(colsWithComma)ubWc = UBound(colsWithComma)If ubWc < 0 Then Exit Function 'nothing todoOn Error GoTo Lerrrws = t.DataBodyRange.Rows.CountLargeclmns = 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 ubWcIf colsWithComma(z) <= clmns ThenMid$(strFlag, colsWithComma(z), 1) = "*"ElseMsgBox ("expand_table> Column " & colsWithComma(z) & " out of table bounds - max=" & clmns)End IfNextApplication.ScreenUpdating = False'IF ALREADY EXISTS A TABLE IN THE POSTOTION OF THE NEW, DELETE ITIf Not topLeftOfNewTable.ListObject Is Nothing ThentopLeftOfNewTable.ListObject.DeleteEnd If'CREATE NEW TABLE TO EXPORT THE ORIGINALSet tex = topLeftOfNewTable.Worksheet.ListObjects.Add(xlSrcRange, topLeftOfNewTable.Resize(1, t.DataBodyRange.Columns.Count), , xlYes)'COPY THE HEADER LINEt.HeaderRowRange.Copy topLeftOfNewTable'redim the array to hold the arrays of columns values, when split themReDim clarr(lbWc To ubWc)For r = 1 To rws' in every row find the column with the maximum elements after splitmaxExp = 0For z = lbWc To ubWcclarr(z) = Split(t.ListRows(r).Range.Cells(, colsWithComma(z)), separator)tmpUb = UBound(clarr(z))If tmpUb > maxExp Then maxExp = tmpUbNext'WE LOOP FROM 0 TO maximum found aboveFor ccex = 0 To maxExpzidx = 0Set lrw = tex.ListRows.AddFor c = 1 To clmnsWith lrw.Range.Cells(, c)'IF THE COLUMN HAVE TO SPLITIf Mid$(strFlag, c, 1) <> " " ThentmpUb = UBound(clarr(zidx))'IF THE ARRAY OF SPLITED VALUES EXIST AND INDEX (ccex) <= UPPER BOUNDIf tmpUb >= 0 And ccex <= tmpUb Then'COPY THE VALUE FROM ARRAY (splitted data).Value2 = clarr(zidx)(ccex)End If'NEXT SPLITING COLUMNzidx = zidx + 1Else'COPY THE ORIGINAL VALUE AS IS.Value2 = t.ListRows(r).Range.Cells(, c)End IfEnd WithNextNextNextSet expand_table = texExit FunctionLerr:If Err.Number > 0 ThenMsgBox ("expand_table>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)End IfOn Error GoTo 0End 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 ListObjectDim rws As Long, clmns As Long, r As Long, c As Long, tex As ListObject, strFlag As StringDim lbWc As Integer, ubWc As Integer, lrw As ListRow, stmp As VariantlbWc = LBound(colsToConcat)ubWc = UBound(colsToConcat)If ubWc < 0 Then Exit Function 'nothing todoOn Error GoTo Lerrrws = t.DataBodyRange.Rows.CountLargeclmns = 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 ubWcIf colsToConcat(c) <= clmns ThenMid$(strFlag, colsToConcat(c), 1) = "*"ElseMsgBox ("shrink_table> Column " & colsToConcat(c) & " out of table bounds - max=" & clmns)Exit FunctionEnd IfNextApplication.ScreenUpdating = False'IF ALREADY EXISTS A TABLE IN THE POSTOTION OF THE NEW, DELETE ITIf Not topLeftOfNewTable.ListObject Is Nothing ThentopLeftOfNewTable.ListObject.DeleteEnd If'COPY THE TABLE't.Range.Copy topLeftOfNewTableSet tex = topLeftOfNewTable.Worksheet.ListObjects.Add(xlSrcRange, topLeftOfNewTable.Resize(1, t.DataBodyRange.Columns.Count), , xlYes)'tex.Name = "TABLEA_CONCAT"t.HeaderRowRange.Copy topLeftOfNewTableSet lrw = tex.ListRows.Addt.ListRows(1).Range.Copy lrw.RangeFor r = 2 To rws'Set lrw = tex.ListRows.AddFor c = 1 To clmns'With lrw.Range.Cells(, c)If Mid$(strFlag, c, 1) = " " ThenIf t.ListRows(r).Range.Cells(, c) <> lrw.Range.Cells(, c) ThenSet lrw = tex.ListRows.Addt.ListRows(r).Range.Copy lrw.RangeGoTo LnextRowEnd IfEnd If'End WithNextFor c = 1 To clmnsIf Mid$(strFlag, c, 1) = " " Then'copy valuelrw.Range.Cells(, c) = t.ListRows(r).Range.Cells(1, c)Else'add valueWith lrw.Range.Cells(, c)stmp = t.ListRows(r).Range.Cells(1, c)If stmp <> vbNullString ThenIf allowDuplicatesInConcat Then.value = .value & separator & stmpElseIf InStr(1, separator & .value & separator, separator & stmp & separator) <= 0 Then.value = .value & separator & stmpEnd IfEnd IfEnd IfEnd WithEnd IfNextLnextRow:NextSet shrink_table = texExit FunctionLerr:If Err.Number > 0 ThenMsgBox ("shrink_table>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)End IfOn Error GoTo 0End Function[![enter image description here][1]][1][1]: https://i.stack.imgur.com/WeA0s.png</details>
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论