逐列、逐行抽取数据进行组合的通用方法

lsdongjh

1. Option Explicit
   
2. 
   
3. '示例
   
4. Sub Test()
   
5.     Dim arrSource As Variant, arrResult As Variant
   
6.     Dim lngCount As Long
   
7.    
   
8.     '抽取【A1:D5】区域的数据进行组合，将结果写入E1起始的单元格
   
9.     '不要求回传结果数量
   
10.     arrSource = Sheet1.Range("A1:D5")
    
11.     If CombinByCol(arrSource, arrResult) Then
    
12.         Sheet1.Range("E1").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
    
13.     End If
    
14.    
    
15.     '抽取【L1:N5】区域的数据进行组合，将结果写入E1起始的单元格
    
16.     '要求回传结果数量
    
17.     arrSource = Sheet1.Range("L1:N5")
    
18.     If CombinByCol(arrSource, arrResult, lngCount) Then
    
19.         Sheet1.Range("Q1").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
    
20.         MsgBox "共有组合" & lngCount & "种"
    
21.     End If
    
22.    
    
23. End Sub
    
24. 
    
25. '**主方法
    
26. '在arrData 区域，逐列、逐行 提取数据进行组合，并将组合结果赋值给arrReturn，结果总数赋值给lngCount
    
27. Function CombinByCol(arrData As Variant, arrReturn As Variant, Optional lngCount As Long) As Boolean
    
28.     Dim arrTemp As Variant, lngRow As Long
    
29.     arrReturn = ""
    
30.     For lngRow = LBound(arrData) To UBound(arrData)
    
31.         ExtractData arrData, arrTemp, LBound(arrData, 2), lngRow, arrReturn
    
32.     Next
    
33.    
    
34.     If IsArray(arrReturn) Then
    
35.         TransRowCol arrReturn
    
36.         lngCount = UBound(arrReturn)
    
37.         CombinByCol = True
    
38.     Else
    
39.         lngCount = 0
    
40.         CombinByCol = False
    
41.     End If
    
42. End Function
    
43. 
    
44. '递归查找
    
45. Private Function ExtractData(ByRef arrSource As Variant, ByRef arrRes As Variant, ByVal ColID As Long, ByVal RowID As Long, arrReturn As Variant)
    
46.     Dim lngRow As Long, lngCol As Long, varTemp As Variant
    
47.     Dim blStart As Boolean, blEnd As Boolean
    
48.     Dim arrValue As Variant
    
49.    
    
50.     '如果是起始列，判断结果集是否存在，不存在则创建
    
51.     If ColID <= LBound(arrSource, 2) Then
    
52.         If Not IsArray(arrRes) Then ReDim arrRes(LBound(arrSource, 2) To UBound(arrSource, 2))
    
53.         ColID = LBound(arrSource, 2)
    
54.     End If
    
55.     '提取数据，判断是否为空，不为空则写入，否则退出
    
56.     varTemp = arrSource(RowID, ColID)
    
57.     If Not CheckData(varTemp) Then Exit Function
    
58.     arrRes(ColID) = varTemp
    
59.     '如果为结束列，表明提取成功，将结果写入，并退出
    
60.     If ColID = UBound(arrSource, 2) Then
    
61.         PutDataToResult arrRes, arrReturn
    
62.         Exit Function
    
63.     End If
    
64.     '递归 提取下一列的数据
    
65.     For lngRow = LBound(arrSource) To UBound(arrSource)
    
66.         ExtractData arrSource, arrRes, ColID + 1, lngRow, arrReturn
    
67.     Next
    
68. End Function
    
69. 
    
70. '将结果写入结果库
    
71. Function PutDataToResult(arrValue As Variant, ByRef arrResultSet As Variant)
    
72.     Dim lngID As Long, lngCol As Long
    
73.     If IsArray(arrResultSet) Then
    
74.         lngID = UBound(arrResultSet, 2) + 1
    
75.     Else
    
76.         ReDim arrResultSet(LBound(arrValue) To UBound(arrValue), 0)
    
77.         lngID = 1
    
78.     End If
    
79.    
    
80.     ReDim Preserve arrResultSet(LBound(arrValue) To UBound(arrValue), 1 To lngID)
    
81.     For lngCol = LBound(arrValue) To UBound(arrValue)
    
82.         arrResultSet(lngCol, lngID) = arrValue(lngCol)
    
83.     Next
    
84. End Function
    
85. 
    
86. '行列转换
    
87. Function TransRowCol(arr As Variant)
    
88.     Dim arrTemp As Variant, lngRow As Long, lngCol As Long
    
89.     ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr) To UBound(arr))
    
90.    
    
91.     For lngRow = LBound(arr) To UBound(arr)
    
92.         For lngCol = LBound(arr, 2) To UBound(arr, 2)
    
93.             arrTemp(lngCol, lngRow) = arr(lngRow, lngCol)
    
94.         Next
    
95.     Next
    
96.     arr = arrTemp
    
97. End Function
    
98. 
    
99. '判断 数据是否为空
    
100. Function CheckData(ByRef Value As Variant) As Boolean
     
101.     Dim strTemp As String
     
102.     strTemp = Trim(CStr(Value))
     
103.     If strTemp = "" Then GoTo ExitFun
     
104.     CheckData = True
     
105.     Exit Function
     
106. ExitFun:
     
107.     CheckData = False
     
108. End Function
     

复制代码

梦幻的流星

建议上传个excel实例

lsdongjh

梦幻的流星 发表于 2021-8-13 19:54
建议上传个excel实例

看一下代码，第一段就是示例

wangziqiang

学习中，感谢了