[已解决]请教：对种类进行组合，所对应的具体数值去重

lygyjt

红色字体是“种类”，每个种类右侧，就是这个种类所对应的具体数值；
在“每个种类所对应的具体数值”表的行号1：6所组成的数组中，将种类（红色字）的个数填入E1，在G1中，手动输入数值，比如3。计算6取3的组合（不是排列），结果放在第2行（A2）开始的下面，每行由3个种类组成。将同行中3个种类各自所对应的具体数值，进行混合去重后，放在第2行（H2）开始的下面。比如：在第2行中，将04、10、12组合（A2:C2）各自后面的具体数值混合去重后，放在H2开始的后面（H2:AI2）。 对种类进行组合，所对应的具体数值去重.rar (20.15 KB, 下载次数: 5)

2021-6-27 17:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-6-27 17:21

Dim a, ar, c, d, n, m, r, num
Sub demo()
   Set d = CreateObject("Scripting.Dictionary")
   Select Case Application.Caller
      Case "按鈕 1": g = 1: n = [e1]:  m = [g1]:  c = "a":  [a2:ao1000] = ""
      Case "按鈕 2": g = 2: n = [au1]: m = [aw1]: c = "aq": [aq2:ce1000] = ""
      Case "按鈕 3": g = 3: n = [ck1]: m = [cm1]: c = "cg": [cg2:dy1000] = ""
   End Select
   ReDim num(1 To 1, 1 To m)
   a = Sheets(1).UsedRange
   ar = (g - 1) * (n + 1)
   r = 1: com 1, 1
End Sub
Sub com(k, i)
   If k > m Then
      r = r + 1
      Cells(r, c).Resize(1, m) = num
      Cells(r, c).Offset(, 7).Resize(1, d.Count) = d.keys
      Exit Sub
   End If
   For i = i To n - m + k
      num(1, k) = a(ar + i, 1)
      For j = 2 To UBound(a, 2)
         Key = a(ar + i, j)
         If Key <> "" Then d(Key) = d(Key) + 1
      Next
      com k + 1, i + 1
      For j = 2 To UBound(a, 2)
         Key = a(ar + i, j)
         If Key <> "" Then
            d(Key) = d(Key) - 1
            If d(Key) = 0 Then d.Remove Key
         End If
      Next
   Next
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Dim a, ar, c, d, n, m, r, num
Sub demo()
   Set d = CreateObject("Scripting.Dictionary")
   Select Case Application.Caller
      Case "按鈕 1": g = 1: n = [e1]:  m = [g1]:  c = "a":  [a2:ao1000] = ""
      Case "按鈕 2": g = 2: n = [au1]: m = [aw1]: c = "aq": [aq2:ce1000] = ""
      Case "按鈕 3": g = 3: n = [ck1]: m = [cm1]: c = "cg": [cg2:dy1000] = ""
   End Select
   ReDim num(1 To 1, 1 To m)
   a = Sheets(1).UsedRange
   ar = (g - 1) * (n + 1)
   r = 1: com 1, 1
End Sub
Sub com(k, i)
   If k > m Then
      r = r + 1
      Cells(r, c).Resize(1, m) = num
      Cells(r, c).Offset(, 7).Resize(1, d.Count) = d.keys
      Exit Sub
   End If
   For i = i To n - m + k
      num(1, k) = a(ar + i, 1)
      For j = 2 To UBound(a, 2)
         Key = a(ar + i, j)
         If Key <> "" Then d(Key) = d(Key) + 1
      Next
      com k + 1, i + 1
      For j = 2 To UBound(a, 2)
         Key = a(ar + i, j)
         If Key <> "" Then
            d(Key) = d(Key) - 1
            If d(Key) = 0 Then d.Remove Key
         End If
      Next
   Next
End Sub

祝順心，南無阿彌陀佛！

lygyjt

cutecpu 发表于 2021-6-27 17:21
Dim a, ar, c, d, n, m, r, num
Sub demo()
   Set d = CreateObject("Scripting.Dictionary")

再次谢谢版主大人啦！帮我解决很多问题了，不只这一个。老师，我还是有不太懂的，还得再麻烦您了：点按钮时，系统提示：ReDim num(1 To 1, 1 To m)，能请您再帮看看吗？

cutecpu

lygyjt 发表于 2021-6-28 16:58
再次谢谢版主大人啦！帮我解决很多问题了，不只这一个。老师，我还是有不太懂的，还得再麻烦您了：点按钮 ...

能上傳會出錯的附件嗎？
我幫您看看

lygyjt

cutecpu 发表于 2021-6-28 16:59
能上傳會出錯的附件嗎？
我幫您看看

好的，马上啊

lygyjt

cutecpu 发表于 2021-6-28 16:59
能上傳會出錯的附件嗎？
我幫您看看

对种类进行组合，所对应的具体数值去重.rar (28.86 KB, 下载次数: 1)

2021-6-28 17:07 上传

点击文件名下载附件

cutecpu

lygyjt 发表于 2021-6-28 17:07

如圖，紅色框選的地方
您那邊的代碼是什麼？
我原來是 繁體 的「按鈕 1」、「按鈕 2」、「按鈕 3」

lygyjt

cutecpu 发表于 2021-6-28 17:12
如圖，紅色框選的地方
您那邊的代碼是什麼？
我原來是 繁體 的「按鈕 1」、「按鈕 2」、「按鈕 3」

我这边就是把您2楼的代码直接粘贴上

cutecpu

lygyjt 发表于 2021-6-28 17:16
我这边就是把您2楼的代码直接粘贴上

你直接下載附件試試！

lygyjt

cutecpu 发表于 2021-6-28 17:12
如圖，紅色框選的地方
您那邊的代碼是什麼？
我原來是 繁體 的「按鈕 1」、「按鈕 2」、「按鈕 3」