为每个列单元格展开列单元格
Posted
技术标签:
【中文标题】为每个列单元格展开列单元格【英文标题】：Expanding column cells for each column cell 【发布时间】：2015-10-06 23:56:09 【问题描述】：我有 3 组不同的数据（在不同的列中）
-
A 列中的动物（5 种不同种类）
B 列中的水果（1000 种不同）
C 列中的国家（10 种不同）
通过这 3 个数据集合，我希望收到 5×1000×10 的 col 中总共 50k 的相应元素。 E F G（每个动物对应每个水果和每个国家）。
这可以通过手动复制和粘贴值来完成，但这需要很长时间。有没有办法通过 VBA 代码或
有没有像上面介绍的那样用于无限数据集的通用公式？如果有什么不清楚的地方请告诉我。
这是一个较小的数据示例以及结果应该如何：
【问题讨论】：
你对你想要的结果的描述对我来说有点模糊。您能否通过仅在 excel 中上传几行的一小部分样本来澄清一下。如果我说您只想将 A、B 和 C 列复制到 E、F 和 G 中，那我是对的吗？ 你好。我已经发布。提供链接：filedropper.com/xmplso请看一下。 我在您的问题中添加了一个打印屏幕。每个摘要行都有两次是有原因的吗？ 其实没有。添加带有修改示例的屏幕截图。感谢您注意到这一点 大猩猩也可以和苹果结合，还是只和香蕉结合？ 【参考方案1】：我通过 universal 收集，您希望它能够容纳任意数量的列和每列中的任意数量的条目。一些变量数组应该提供计算每个值的重复周期所需的维度。
Option Explicit
Sub main()
Call for_each_in_others(rDATA:=Worksheets("Sheet3").Range("A3"), bHDR:=True)
End Sub
Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
Dim v As Long, w As Long
Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With rDATA.Parent
With rDATA(1).CurrentRegion
'Debug.Print rDATA(1).Row - .Cells(1).Row
With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
sErrorRng = .Address(0, 0)
vTMPs = .Value2
ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
iMAXROWS = 1
'On Error GoTo bm_Output_Exceeded
For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
vCOLs(w) = Application.CountA(.Columns(w))
iMAXROWS = iMAXROWS * vCOLs(w)
Next w
'control excessive or no rows of output
If iMAXROWS > Rows.Count Then
GoTo bm_Output_Exceeded
ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
GoTo bm_Nothing_To_Do
End If
On Error GoTo bm_Safe_Exit
ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
iINCROWS = 1
For w = LBound(vVALs, 2) To UBound(vVALs, 2)
iINCROWS = iINCROWS * vCOLs(w)
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
Next v
Next w
End With
End With
.Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
If bHDR Then
rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
End If
rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
GoTo bm_Safe_Exit
bm_Nothing_To_Do:
MsgBox "There is not enough data in " & sErrorRng & " to perform expansion." & Chr(10) & _
"This could be due to a single column of values or one or more blank column(s) of values." & _
Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
"Single or No Column of Raw Data"
GoTo bm_Safe_Exit
bm_Output_Exceeded:
MsgBox "The number of expanded values created from " & sErrorRng & _
" (" & Format(iMAXROWS, "\> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
" columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
"Too Many Entries"
bm_Safe_Exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.EnableEvents = bTGGL
Application.ScreenUpdating = bTGGL
End Sub
将列标题标签放在从 A 列开始的第 2 行中，然后将数据放在该列的正下方。
我添加了一些错误控制来警告超出工作表上的行数。这通常不是可能需要考虑的事情，但是将未确定数量的列中的值数量相乘可以快速产生大量结果。超过 1,048,576 行并非不可预见。
【讨论】：
您为此编写的 VBA 速度非常快，我打算更仔细地研究它；但是，当我根据机会实际数据集（5 个动物、1000 个水果、10 个国家/地区）运行宏时，出现运行时错误 6：溢出。 感谢您的发现。在乘法运算之前，我必须将除法运算括在括号中以获得数学优先级。见this。我会在短时间内为这篇文章添加一些错误控制和数学公式修复。 减 1 用于合并单元格。开玩笑！ （我一直这样做）我试图在凌晨 1:00 从头开始写这个，但我无法处理数学。之前抛出异常的代码行是我想不出来的。 吉普德你好。感谢你的付出。似乎您的宏适用于 3 个数据集 - 我已经尝试过了，这真的很棒。对于 635184 行的 802x198x4 数据集，在近 5 秒内返回！异常奇葩！非常感谢！还针对 4 列和 5 列进行了测试，并且运行良好。只是现在似乎唯一的限制是 excel 工作簿 @mysticous 您是否认为在运行此过程时 Excel 的行限制会成为您的问题？换句话说，是否会出现输出可能超过一百万行的情况？【参考方案2】：非连接选择 SQL 语句的经典示例，它返回列出的表的所有组合结果的笛卡尔积。
SQL 数据库解决方案
只需将 Animals、Fruit、Country 作为单独的表导入到任何 SQL 数据库（如 MS Access、SQLite、mysql 等）中，并列出没有连接的表，包括隐式 (WHERE) 和显式 (JOIN) 连接：
SELECT Animals.Animal, Fruits.Fruit, Countries.Country
FROM Animals, Countries, Fruits;
Excel 解决方案
与在 VBA 中运行非连接 SQL 语句的概念相同，该语句使用 ODBC 连接到包含动物、国家和水果范围的工作簿。例如，每个数据分组都在其自己的同名工作表中。
Sub CrossJoinQuery()
Dim conn As Object
Dim rst As Object
Dim sConn As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sConn = "Driver=Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb);" _
& "DBQ=C:\Path To\Excel\Workbook.xlsx;"
conn.Open sConn
strSQL = "SELECT * FROM [Animals$A1:A3], [Fruits$A1:A3], [Countries$A1:A3] "
rst.Open strSQL, conn
Range("A1").CopyFromRecordset rst
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub
【讨论】：
你好。感谢您提供此解决方案。您也可以通过交叉连接来执行此操作，但假设用户无法通过 MS SQL 或 Access 解决此问题 使用 Excel 解决方案查看我的更新。与运行非连接 SQL 语句的概念相同。【参考方案3】：我解决这个问题的第一种方法类似于@Jeeped 发布的方法：
-
将输入列加载到数组并计算每列中的行数
用所有组合填充数组
将数组分配给输出范围
使用MicroTimer 我计算了上述算法每个部分的平均时间。第 3 部分。为更大的输入数据占用了总执行时间的 90%-93%。
以下是我尝试提高将数据写入工作表的速度。我已经定义了一个常量iMinRSize=17。一旦可以用相同的值填充超过iMinRSize 的连续行，代码将停止归档数组并直接写入工作表范围。
Sub CrossJoin(rSrc As Range, rTrg As Range)
Dim vSrc() As Variant, vTrgPart() As Variant
Dim iLengths() As Long
Dim iCCnt As Integer, iRTrgCnt As Long, iRSrcCnt As Long
Dim i As Integer, j As Long, k As Long, l As Long
Dim iStep As Long
Const iMinRSize As Long = 17
Dim iArrLastC As Integer
On Error GoTo CleanUp
Application.ScreenUpdating = False
Application.EnableEvents = False
vSrc = rSrc.Value2
iCCnt = UBound(vSrc, 2)
iRSrcCnt = UBound(vSrc, 1)
iRTrgCnt = 1
iArrLastC = 1
ReDim iLengths(1 To iCCnt)
For i = 1 To iCCnt
j = iRSrcCnt
While (j > 0) And IsEmpty(vSrc(j, i))
j = j - 1
Wend
iLengths(i) = j
iRTrgCnt = iRTrgCnt * iLengths(i)
If (iRTrgCnt < iMinRSize) And (iArrLastC < iCCnt) Then iArrLastC = iArrLastC + 1
Next i
If (iRTrgCnt > 0) And (rTrg.row + iRTrgCnt - 1 <= rTrg.Parent.Rows.Count) Then
ReDim vTrgPart(1 To iRTrgCnt, 1 To iArrLastC)
iStep = 1
For i = 1 To iArrLastC
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
For l = j To j + iStep - 1
vTrgPart(l, i) = vSrc(k, i)
Next l
Next j
iStep = iStep * iLengths(i)
Next i
rTrg.Resize(iRTrgCnt, iArrLastC) = vTrgPart
For i = iArrLastC + 1 To iCCnt
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
rTrg.Resize(iStep).Offset(j - 1, i - 1).Value2 = vSrc(k, i)
Next j
iStep = iStep * iLengths(i)
Next i
End If
CleanUp:
Application.ScreenUpdating = True
Application.EnableEvents = False
End Sub
Sub test()
CrossJoin Range("a2:f10"), Range("k2")
End Sub
如果我们将iMinRSize 设置为Rows.Count，则所有数据都会写入数组。以下是我的样本测试结果：
如果行数最多的输入列在前，该代码效果最佳，但修改代码以对列进行排序并按正确顺序处理不会有大问题。
【讨论】：
这是速度和彻底性的赢家。感谢您花时间解释和演示速度测试。【参考方案4】：您可以使用工作表公式来做到这一点。 如果您有 NAME 的范围 - 动物、水果和国家，“诀窍”是在该数组中生成索引以提供所有各种组合。
例如：
=CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)
将生成一个从 1 开始的数字系列，这些数字在 Fruits * Country 中的数字条目中重复 - 这为您提供每种动物所需的行数。
=MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1
将生成一个从 1 开始的系列，该系列会针对多个国家/地区重复每个水果。
=MOD(ROWS($1:1)-1,ROWS(Countries))+1))
生成 1..n 的重复序列，其中 n 是国家/地区的数量。
将这些放入公式（带有一些错误检查）
D3: =IFERROR(INDEX(Animals,CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)),"")
E3: =IF(E3="","",INDEX(Fruits,MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1))
F3: =IF(E3="","",INDEX(Countries,MOD(ROWS($1:1)-1,ROWS(Countries))+1))
【讨论】：
谢谢。非常好的解决方案:-) 很清楚，正如我所假设的那样——如果我想在“原始数据”中添加下一个变量，我应该使用 E3 行吗？如果不清楚 - 我会尽力解释。只是想 - 我如何将它用于不同的数据集。 @mysticous 我不明白您在此评论中的问题 我的意思是——这个公式只适用于这个例子吗？或者我应该如何重新排列可调整原始数据可变数据集的公式。希望它澄清。如果没有 - 请告诉我。 @mysticous 无论数据集的大小如何，您都可以应用相同的主体。如果您添加更多行，我建议使用动态名称。对于更多列，您需要重写公式。 @mysticous 如果您还希望能够改变列数，并从计算中排除每列中的空白，VBA 解决方案会更加灵活。【参考方案5】：实际上，我想修改我的旧答案。但是，我的新答案与旧答案完全不同。因为，旧答案是针对特定列的，而这个答案是针对通用列的。在回答了旧答案后，提问者说出了他想要通用的新要求。对于固定列，我们可以考虑固定循环，对于无限列，我们需要换一种方式思考。所以，我也这样做。 SO用户也可以看到代码差异，我认为这对初学者会有帮助。
这个新代码不像旧代码那么简单。如果您想清楚地了解代码，我建议您逐行调试代码。
不用担心代码。我已经逐步测试了它。它非常适合我。如果它不适合你，请告诉我。一件事是此代码可能会导致空白行（没有数据）出错。因为，目前，我没有添加检查。
这是我解决问题的通用方法：
Public Sub matchingCell()
Dim startRawColumn, endRawColumn, startResultColumn, endResultColumn, startRow As Integer
Dim index, row, column, containerIndex, tempIndex As Integer
Dim columnCount, totalCount, timesCount, matchingCount, tempCount As Integer
Dim isExist As Boolean
Dim arrayContainer() As Variant
'Actually, even it is for universal, we need to know start column and end column of raw data.
'And also start row. And start column for write result.
'I set them for my test data.
'You need to modify them(startRawColumn, endRawColumn, startRow, startResultColumn).
'Set the start column and end column for raw data
startRawColumn = 1
endRawColumn = 3
'Set the start row for read data and write data
startRow = 2
'Set the start column for result data
startResultColumn = 4
'Get no of raw data column
columnCount = endRawColumn - startRawColumn
'Set container index
containerIndex = 0
'Re-create array container for count of column
ReDim arrayContainer(0 To columnCount)
With Sheets("sheetname")
'Getting data from sheet
'Loop all column for getting data of each column
For column = startRawColumn To endRawColumn Step 1
'Create tempArray for column
Dim tempArray() As Variant
'Reset startRow
row = startRow
'Reset index
index = 0
'Here is one things. I looped until to blank.
'If you want anymore, you can modify the looping type.
'Don't do any changes to main body of looping.
'Loop until the cell is blank
Do While .Cells(row, column) <> ""
'Reset isExist flag
isExist = False
'Remove checking for no data
If index > 0 Then
'Loop previous data for duplicate checking
For tempIndex = 0 To index - 1 Step 1
'If found, set true to isExist and stop loop
If tempArray(tempIndex) = .Cells(row, column) Then
isExist = True
Exit For
End If
Next tempIndex
End If
'If there is no duplicate data, store data
If Not isExist Then
'Reset tempArray
ReDim Preserve tempArray(index)
tempArray(index) = .Cells(row, column)
'Increase index
index = index + 1
End If
'Increase row
row = row + 1
Loop
'Store column with data
arrayContainer(containerIndex) = tempArray
'Increase container index
containerIndex = containerIndex + 1
Next column
'Now, we got all data column including data which has no duplicate
'Show result data on sheet
'Getting the result row count
totalCount = 1
'Get result row count
For tempIndex = 0 To UBound(arrayContainer) Step 1
totalCount = totalCount * (UBound(arrayContainer(tempIndex)) + 1)
Next tempIndex
'Reset timesCount
timesCount = 1
'Get the last column for result
endResultColumn = startResultColumn + columnCount
'Loop array container
For containerIndex = UBound(arrayContainer) To 0 Step -1
'Getting the counts for looping
If containerIndex = UBound(arrayContainer) Then
duplicateCount = 1
timesCount = totalCount / (UBound(arrayContainer(containerIndex)) + 1)
Else
duplicateCount = duplicateCount * (UBound(arrayContainer(containerIndex + 1)) + 1)
timesCount = timesCount / (UBound(arrayContainer(containerIndex)) + 1)
End If
'Reset the start row
row = startRow
'Loop timesCount
For countIndex = 1 To timesCount Step 1
'Loop data array
For index = 0 To UBound(arrayContainer(containerIndex)) Step 1
'Loop duplicateCount
For tempIndex = 1 To duplicateCount Step 1
'Write data to cell
.Cells(row, endResultColumn) = arrayContainer(containerIndex)(index)
'Increase row
row = row + 1
Next tempIndex
Next index
Next countIndex
'Increase result column index
endResultColumn = endResultColumn - 1
Next containerIndex
End With
End Sub
【讨论】：
我总是运行Option Explicit，所以我必须声明Dim duplicateCount As Long, countIndex As Long。我也得到了 2 列输出，但这可能是我的示例数据；稍后我会对此进行更多研究。
其实我没有使用Option Explicit的习惯。所以，我忘了声明一下。使用Option Explicit 是一个很好的习惯。我添加了一些声明。我修改了获取总行数的循环起点，因为我一次又一次地测试它时发现了一个错误。谢谢你的建议。
这是一个更好的版本。我倾向于在这里奖励赏金，但平心而论，我必须采用 user3964075 提出的解决方案，只是因为速度如此之快。我希望你已经收到了足够多的支持，让这值得你花时间。 fwiw，虽然比另一个慢一点，但这可能更容易理解。
嗨@Nicolas。我在不同的数据集上尝试了此代码，但似乎收到错误“下标超出范围”。你能给点建议吗？
哪一行给你错误，你的数据集是什么。【参考方案6】：
这是一个递归版本。它假定数据不包含任何内部制表符，因为核心函数返回以制表符分隔的产品 字符串。主子需要传递一个由数据组成的范围以及输出范围的左上角单元格。这可能会稍作调整，但足以用于测试目的。
ColumnProducts Range("A:C"), Range("E1")
是解决 OP 问题的调用。代码如下：
'the following function takes a collection of arrays of strings
'and returns a variant array of tab-delimited strings which
'comprise the (tab-delimited) cartesian products of
'the arrays in the collection
Function CartesianProduct(ByVal Arrays As Collection) As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim head As Variant
Dim tail As Variant
Dim product As Variant
If Arrays.Count = 1 Then
CartesianProduct = Arrays.Item(1)
Exit Function
Else
head = Arrays.Item(1)
Arrays.Remove 1
tail = CartesianProduct(Arrays)
m = UBound(head)
n = UBound(tail)
ReDim product(1 To m * n)
k = 1
For i = 1 To m
For j = 1 To n
product(k) = head(i) & vbTab & tail(j)
k = k + 1
Next j
Next i
CartesianProduct = product
End If
End Function
Sub ColumnProducts(data As Range, output As Range)
Dim Arrays As New Collection
Dim strings As Variant, product As Variant
Dim i As Long, j As Long, n As Long, numRows As Long
Dim col As Range, cell As Range
Dim outRange As Range
numRows = Range("A:A").Rows.Count
For Each col In data.Columns
n = col.EntireColumn.Cells(numRows).End(xlUp).Row
i = col.Cells(1).Row
ReDim strings(1 To n - i + 1)
For j = 1 To n - i + 1
strings(j) = col.Cells(i + j - 1)
Next j
Arrays.Add strings
Next col
product = CartesianProduct(Arrays)
n = UBound(product)
Set outRange = Range(output, output.Offset(n - 1))
outRange.Value = Application.WorksheetFunction.Transpose(product)
outRange.TextToColumns Destination:=output, DataType:=xlDelimited, Tab:=True
End Sub
【讨论】：
这适用于规定范围内的数据，但如果仅添加更多数据值，则会很快遇到运行时错误 13：.Transpose 操作上的类型不匹配。 Transpose 的限制远远低于现代工作表的限制（请参阅here）。【参考方案7】：
好的，所以您只需要一个所有可能组合的列表。这是我会做的：
首先选择原始数据并逐列删除重复项。 然后将这 3 列读入 3 个单独的数组。 计算所有数组的总长度。 然后使用循环粘贴国家数组的第一个值，次数与动物和水果的组合一样多，因此这些数组的长度成倍增加。 在循环中创建另一个循环，发布所有水果选项。重复行数等于动物的最大数量。 然后将不重复的动物依次粘贴到表格的最后一行。【讨论】：
【参考方案8】：这里，我解决你的问题的方法。
Public Sub matchingCell()
Dim animalRow, fruitRow, countryRow, checkRow, resultRow As Long
Dim isExist As Boolean
'Set the start row
animalRow = 2
resultRow = 2
'Work with data sheet
With Sheets("sheetname")
'Loop until animals column is blank
Do While .Range("A" & animalRow) <> ""
'Set the start row
fruitRow = 2
'Loop until fruits column is blank
Do While .Range("B" & fruitRow) <> ""
'Set the start row
countryRow = 2
'Loop until country column is blank
Do While .Range("C" & countryRow) <> ""
'Set the start row
checkRow = 2
'Reset flag
isExist = False
'Checking for duplicate row
'Loop all result row until D is blank
Do While .Range("D" & checkRow) <> ""
'If duplicate row found
If .Range("D" & checkRow) = .Range("A" & animalRow) And _
.Range("E" & checkRow) = .Range("B" & fruitRow) And _
.Range("F" & checkRow) = .Range("C" & countryRow) Then
'Set true for exist flag
isExist = True
End If
checkRow = checkRow + 1
Loop
'If duplicate row not found
If Not isExist Then
.Range("D" & resultRow) = .Range("A" & animalRow)
.Range("E" & resultRow) = .Range("B" & fruitRow)
.Range("F" & resultRow) = .Range("C" & countryRow)
'Increase resultRow
resultRow = resultRow + 1
End If
'Increase countryRow
countryRow = countryRow + 1
Loop
'Increase fruitRow
fruitRow = fruitRow + 1
Loop
'Increase fruitRow
animalRow = animalRow + 1
Loop
End With
End Sub
我已经测试过了。它运作良好。祝你有美好的一天。
【讨论】：
谢谢尼古拉斯。我真的很感谢你的帮助。但是你能帮我以更通用的方式使用它吗？比如无限列？右侧会显示哪些数据？ 你的意思是几列，你想匹配这些所有列并导出结果？ 几个列，例如 now 宏被定义为精确的三个定义的名称。现在我想以一般方式使用它，因为对于具有不同标题和不同样本的不同数据集，此问题会多次发生。而且其实我对VBA的调代码也不是很熟练。 不能。我需要确认的一件事是“我们能否知道每次数据集的列数”。修好了就可以编码了。 是否有可能是从 2 到 10 的区间？如果有 2 - 接下来的 8 个是空白？以上是关于为每个列单元格展开列单元格的主要内容，如果未能解决你的问题，请参考以下文章
excel中的一列每个单元格内容的前面统一添加同样的文字怎么做？