设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求助用VBA组合相同数
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1771|回复: 8

[已解决]求助用VBA组合相同数

[复制链接]
三田
发表于 2013-1-27 09:55 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
相同数.rar (6.96 KB, 下载次数: 27)
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-1-27 11:02 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Option Explicit

  3. Sub 组合数()
  4.     Dim arr
  5.     Dim arr2()
  6.     Dim arr3(1 To 3)
  7.     Dim dic As Object
  8.     Dim i&, j&, k&, x, y, z
  9.     Dim check As Boolean
  10.    
  11.     arr = Range("c1").CurrentRegion
  12.     Set dic = CreateObject("scripting.dictionary")
  13.     For i = LBound(arr) + 1 To UBound(arr) Step 2
  14.         For j = LBound(arr, 2) To UBound(arr, 2)
  15.             Call splitnumber(arr(i, j), dic)
  16.             Call splitnumber(arr(i + 1, j), dic)
  17.             Call Anydic(dic)
  18.             If dic.Count = 0 Then check = False: dic.RemoveAll: Exit For
  19.             arr3(j) = dic.keys
  20.             check = True
  21.             dic.RemoveAll
  22.         Next
  23.         If check Then
  24.             For Each x In arr3(1)
  25.                 For Each y In arr3(2)
  26.                     For Each z In arr3(3)
  27.                         k = k + 1
  28.                         ReDim Preserve arr2(1 To k)
  29.                         arr2(k) = x * 100 + y * 10 + z
  30.                     Next
  31.                 Next
  32.             Next
  33.         End If
  34.     Next
  35.     Columns("m").Clear
  36.     Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  37.     Set dic = Nothing
  38.     MsgBox "提取完成"
  39. End Sub

  41. Sub splitnumber(ByVal number, ByRef dic As Object)
  42.     Dim i, s$
  43.     For i = 1 To Len(number)
  44.         s = Mid(number, i, 1)
  45.         dic(s) = dic(s) + 1
  46.     Next
  47. End Sub

  49. Sub Anydic(ByRef dic As Object)
  50.     Dim key
  51.     For Each key In dic.keys
  52.         If dic(key) = 1 Then dic.Remove key
  53.     Next
  54. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 11:09 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Option Explicit

  3. Sub 组合数()
  4. '---------------------------------------------------------------------------------------
  5. ' Procedure : 组合数
  6. ' Author    : hwc2ycy
  7. ' Date      : 2013/1/27
  8. ' Purpose   :
  9. '---------------------------------------------------------------------------------------
  10. '
  11.     Dim arr
  12.     Dim arr2()
  13.     Dim arr3(1 To 3)
  14.     Dim dic As Object
  15.     Dim i&, j&, k&, x, y, z
  16.     Dim Check As Boolean

  18.     '读数据到字典，因为用的是区域法，所以要确保在数字区域
  19.     '无其他内容
  20.     arr = Range("c1").CurrentRegion
  21.     '字典
  22.     Set dic = CreateObject("scripting.dictionary")
  23.     '遍历数组，2行一次
  24.     For i = LBound(arr) + 1 To UBound(arr) Step 2
  25.         For j = LBound(arr, 2) To UBound(arr, 2)
  26.             Call splitnumber(arr(i, j), dic)
  27.             Call splitnumber(arr(i + 1, j), dic)
  28.             Call AnyDic(dic)
  29.             '如果没有共同数据，则结束本轮循环，字典清空
  30.             If dic.Count = 0 Then Check = False: dic.RemoveAll: Exit For
  31.             arr3(j) = dic.keys
  32.             '能否进行组合的前提条件
  33.             Check = True
  34.             dic.RemoveAll
  35.         Next
  36.         If Check Then
  37.             '遍历，生成组合,x,y,z分别代表百，拾，个位
  38.             For Each x In arr3(1)
  39.                 For Each y In arr3(2)
  40.                     For Each z In arr3(3)
  41.                         '动态数组
  42.                         k = k + 1
  43.                         ReDim Preserve arr2(1 To k)
  44.                         arr2(k) = x * 100 + y * 10 + z
  45.                     Next
  46.                 Next
  47.             Next
  48.         End If
  49.     Next
  50.     Columns("m").Clear
  51.     '一维变二维，写回M列
  52.     Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  53.     Set dic = Nothing
  54.     MsgBox "提取完成"
  55. End Sub

  57. Sub splitnumber(ByVal number, ByRef dic As Object)
  58. '---------------------------------------------------------------------------------------
  59. ' Procedure : splitnumber
  60. ' Author    : hwc2ycy
  61. ' Date      : 2013/1/27
  62. ' Purpose   :把数字拆分装进字典
  63. '---------------------------------------------------------------------------------------
  64. '
  65.     Dim i, s$
  66.     For i = 1 To Len(number)
  67.         s = Mid(number, i, 1)
  68.         dic(s) = dic(s) + 1
  69.     Next
  70. End Sub

  72. Sub AnyDic(ByRef dic As Object)
  73. '---------------------------------------------------------------------------------------
  74. ' Procedure : AnyDic
  75. ' Author    : hwc2ycy
  76. ' Date      : 2013/1/27
  77. ' Purpose   :分析字典，去掉没有重复数的
  78. '---------------------------------------------------------------------------------------
  79. '
  80.     Dim key
  81.     For Each key In dic.keys
  82.         If dic(key) = 1 Then dic.Remove key
  83.     Next
  84. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 11:16 | 显示全部楼层
增加对非数字字符的判断，以免出错。
  1. Option Explicit

  3. Sub 组合数()
  4. '---------------------------------------------------------------------------------------
  5. ' Procedure : 组合数
  6. ' Author    : hwc2ycy
  7. ' Date      : 2013/1/27
  8. ' Purpose   :字典与数组的应用
  9. '---------------------------------------------------------------------------------------
  10. '
  11.     Dim arr
  12.     Dim arr2()
  13.     Dim arr3(1 To 3)
  14.     Dim dic As Object
  15.     Dim i&, j&, k&, x, y, z
  16.     Dim Check As Boolean

  18.     '读数据到字典，因为用的是区域法，所以要确保在数字区域
  19.     '无其他内容
  20.     arr = Range("c1").CurrentRegion
  21.     '字典
  22.     Set dic = CreateObject("scripting.dictionary")
  23.     '遍历数组，2行一次
  24.     For i = LBound(arr) + 1 To UBound(arr) Step 2
  25.         For j = LBound(arr, 2) To UBound(arr, 2)
  26.             '如果数据为非数字（或者为0）的情况下，则跳出本轮循环
  27.             If Not (Val(arr(i, j)) > 0 And Val(arr(i + 1, j)) > 0) Then GoTo quit
  28.             Call splitnumber(arr(i, j), dic)
  29.             Call splitnumber(arr(i + 1, j), dic)
  30.             Call AnyDic(dic)

  32.             '如果没有共同数据，则结束本轮循环，字典清空
  33.             If dic.Count = 0 Then
  34. quit:
  35.                 Check = False
  36.                 dic.RemoveAll
  37.                 Exit For
  38.             End If

  40.             arr3(j) = dic.keys
  41.             '能否进行组合的前提条件
  42.             Check = True
  43.             dic.RemoveAll
  44.         Next
  45.         If Check Then
  46.             '遍历，生成组合,x,y,z分别代表百，拾，个位
  47.             For Each x In arr3(1)
  48.                 For Each y In arr3(2)
  49.                     For Each z In arr3(3)
  50.                         '动态数组
  51.                         k = k + 1
  52.                         ReDim Preserve arr2(1 To k)
  53.                         arr2(k) = x * 100 + y * 10 + z
  54.                     Next
  55.                 Next
  56.             Next
  57.         End If
  58.     Next
  59.     Columns("m").Clear
  60.     '一维变二维，写回M列
  61.     Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  62.     Set dic = Nothing
  63.     MsgBox "提取完成"
  64. End Sub

  66. Sub splitnumber(ByVal number, ByRef dic As Object)
  67. '---------------------------------------------------------------------------------------
  68. ' Procedure : splitnumber
  69. ' Author    : hwc2ycy
  70. ' Date      : 2013/1/27
  71. ' Purpose   :把数字拆分装进字典
  72. '---------------------------------------------------------------------------------------
  73. '
  74.     Dim i, s$
  75.     For i = 1 To Len(number)
  76.         s = Mid(number, i, 1)
  77.         dic(s) = dic(s) + 1
  78.     Next
  79. End Sub

  81. Sub AnyDic(ByRef dic As Object)
  82. '---------------------------------------------------------------------------------------
  83. ' Procedure : AnyDic
  84. ' Author    : hwc2ycy
  85. ' Date      : 2013/1/27
  86. ' Purpose   :分析字典，去掉没有重复数的
  87. '---------------------------------------------------------------------------------------
  88. '
  89.     Dim key
  90.     For Each key In dic.keys
  91.         If dic(key) = 1 Then dic.Remove key
  92.     Next
  93. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 11:20 | 显示全部楼层
再改进，避免没有生成组合数的情况下写入报错。
  1. Option Explicit

  3. Sub 组合数()
  4. '---------------------------------------------------------------------------------------
  5. ' Procedure : 组合数
  6. ' Author    : hwc2ycy
  7. ' Date      : 2013/1/27
  8. ' Purpose   :字典与数组的应用
  9. '---------------------------------------------------------------------------------------
  10. '
  11.     Dim arr
  12.     Dim arr2()
  13.     Dim arr3(1 To 3)
  14.     Dim dic As Object
  15.     Dim i&, j&, k&, x, y, z
  16.     Dim Check As Boolean

  18.     '读数据到字典，因为用的是区域法，所以要确保在数字区域
  19.     '无其他内容
  20.     arr = Range("c1").CurrentRegion
  21.     '字典
  22.     Set dic = CreateObject("scripting.dictionary")
  23.     '遍历数组，2行一次
  24.     For i = LBound(arr) + 1 To UBound(arr) Step 2
  25.         For j = LBound(arr, 2) To UBound(arr, 2)
  26.             '如果数据为非数字（或者为0）的情况下，则跳出本轮循环
  27.             If Not (Val(arr(i, j)) > 0 And Val(arr(i + 1, j)) > 0) Then GoTo quit
  28.             Call splitnumber(arr(i, j), dic)
  29.             Call splitnumber(arr(i + 1, j), dic)
  30.             Call AnyDic(dic)

  32.             '如果没有共同数据，则结束本轮循环，字典清空
  33.             If dic.Count = 0 Then
  34. quit:
  35.                 Check = False
  36.                 dic.RemoveAll
  37.                 Exit For
  38.             End If

  40.             arr3(j) = dic.keys
  41.             '能否进行组合的前提条件
  42.             Check = True
  43.             dic.RemoveAll
  44.         Next
  45.         If Check Then
  46.             '遍历，生成组合,x,y,z分别代表百，拾，个位
  47.             For Each x In arr3(1)
  48.                 For Each y In arr3(2)
  49.                     For Each z In arr3(3)
  50.                         '动态数组
  51.                         k = k + 1
  52.                         ReDim Preserve arr2(1 To k)
  53.                         arr2(k) = x * 100 + y * 10 + z
  54.                     Next
  55.                 Next
  56.             Next
  57.         End If
  58.     Next
  59.     If k > 0 Then
  60.         Columns("m").Clear
  61.         '一维变二维，写回M列
  62.         Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  63.         MsgBox "提取完成"
  64.     Else
  65.         MsgBox "数据中无相同数据，组合结果为0"
  66.     End If
  67.     Set dic = Nothing

  69. End Sub

  71. Sub splitnumber(ByVal number, ByRef dic As Object)
  72. '---------------------------------------------------------------------------------------
  73. ' Procedure : splitnumber
  74. ' Author    : hwc2ycy
  75. ' Date      : 2013/1/27
  76. ' Purpose   :把数字拆分装进字典
  77. '---------------------------------------------------------------------------------------
  78. '
  79.     Dim i, s$
  80.     For i = 1 To Len(number)
  81.         s = Mid(number, i, 1)
  82.         dic(s) = dic(s) + 1
  83.     Next
  84. End Sub

  86. Sub AnyDic(ByRef dic As Object)
  87. '---------------------------------------------------------------------------------------
  88. ' Procedure : AnyDic
  89. ' Author    : hwc2ycy
  90. ' Date      : 2013/1/27
  91. ' Purpose   :分析字典，去掉没有重复数的
  92. '---------------------------------------------------------------------------------------
  93. '
  94.     Dim key
  95.     For Each key In dic.keys
  96.         If dic(key) = 1 Then dic.Remove key
  97.     Next
  98. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 11:22 | 显示全部楼层    本楼为最佳答案   
本帖最后由 hwc2ycy 于 2013-1-27 11:23 编辑

对于百位为0，没有显示出来。
如果要显示出来在百位为0的情况，代码就用这个。
  1. Option Explicit

  3. Sub 组合数()
  4. '---------------------------------------------------------------------------------------
  5. ' Procedure : 组合数
  6. ' Author    : hwc2ycy
  7. ' Date      : 2013/1/27
  8. ' Purpose   :字典与数组的应用
  9. '---------------------------------------------------------------------------------------
  10. '
  11.     Dim arr
  12.     Dim arr2()
  13.     Dim arr3(1 To 3)
  14.     Dim dic As Object
  15.     Dim i&, j&, k&, x, y, z
  16.     Dim Check As Boolean

  18.     '读数据到字典，因为用的是区域法，所以要确保在数字区域
  19.     '无其他内容
  20.     arr = Range("c1").CurrentRegion
  21.     '字典
  22.     Set dic = CreateObject("scripting.dictionary")
  23.     '遍历数组，2行一次
  24.     For i = LBound(arr) + 1 To UBound(arr) Step 2
  25.         For j = LBound(arr, 2) To UBound(arr, 2)
  26.             '如果数据为非数字（或者为0）的情况下，则跳出本轮循环
  27.             If Not (Val(arr(i, j)) > 0 And Val(arr(i + 1, j)) > 0) Then GoTo quit
  28.             Call splitnumber(arr(i, j), dic)
  29.             Call splitnumber(arr(i + 1, j), dic)
  30.             Call AnyDic(dic)

  32.             '如果没有共同数据，则结束本轮循环，字典清空
  33.             If dic.Count = 0 Then
  34. quit:
  35.                 Check = False
  36.                 dic.RemoveAll
  37.                 Exit For
  38.             End If

  40.             arr3(j) = dic.keys
  41.             '能否进行组合的前提条件
  42.             Check = True
  43.             dic.RemoveAll
  44.         Next
  45.         If Check Then
  46.             '遍历，生成组合,x,y,z分别代表百，拾，个位
  47.             For Each x In arr3(1)
  48.                 For Each y In arr3(2)
  49.                     For Each z In arr3(3)
  50.                         '动态数组
  51.                         k = k + 1
  52.                         ReDim Preserve arr2(1 To k)
  53.                         arr2(k) = "'" & Format(x * 100 + y * 10 + z, "000")
  54.                     Next
  55.                 Next
  56.             Next
  57.         End If
  58.     Next
  59.     Columns("m").Clear
  60.     If k > 0 Then

  62.         '一维变二维，写回M列
  63.         Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  64.         MsgBox "提取完成"
  65.     Else
  66.         MsgBox "数据中无相同数据，组合结果为0"
  67.     End If
  68.     Set dic = Nothing

  70. End Sub

  72. Sub splitnumber(ByVal number, ByRef dic As Object)
  73. '---------------------------------------------------------------------------------------
  74. ' Procedure : splitnumber
  75. ' Author    : hwc2ycy
  76. ' Date      : 2013/1/27
  77. ' Purpose   :把数字拆分装进字典
  78. '---------------------------------------------------------------------------------------
  79. '
  80.     Dim i, s$
  81.     For i = 1 To Len(number)
  82.         s = Mid(number, i, 1)
  83.         dic(s) = dic(s) + 1
  84.     Next
  85. End Sub

  87. Sub AnyDic(ByRef dic As Object)
  88. '---------------------------------------------------------------------------------------
  89. ' Procedure : AnyDic
  90. ' Author    : hwc2ycy
  91. ' Date      : 2013/1/27
  92. ' Purpose   :分析字典，去掉没有重复数的
  93. '---------------------------------------------------------------------------------------
  94. '
  95.     Dim key
  96.     For Each key In dic.keys
  97.         If dic(key) = 1 Then dic.Remove key
  98.     Next
  99. End Sub
复制代码
回复

使用道具 举报

三田
 楼主| 发表于 2013-1-27 12:08 | 显示全部楼层
hwc2ycy 发表于 2013-1-27 11:22
对于百位为0，没有显示出来。
如果要显示出来在百位为0的情况，代码就用这个。

结果里少了C3:E4里面的216,516两组数
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 13:04 | 显示全部楼层
本帖最后由 hwc2ycy 于 2013-1-27 13:06 编辑

哦。我直接跳过一行了。
改一下就成了。把
  1.     For i = LBound(arr) + 1 To UBound(arr) Step 2
复制代码
改成
  1.     For i = LBound(arr) + 1 To UBound(arr)-1
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-1-27 13:06 | 显示全部楼层
  1. Sub 组合数()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 组合数
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/1/27
  6. ' Purpose   :字典与数组的应用
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim arr
  10.     Dim arr2()
  11.     Dim arr3(1 To 3)
  12.     Dim dic As Object
  13.     Dim i&, j&, k&, x, y, z
  14.     Dim Check As Boolean

  16.     '读数据到字典，因为用的是区域法，所以要确保在数字区域
  17.     '无其他内容
  18.     arr = Range("c1").CurrentRegion
  19.     '字典
  20.     Set dic = CreateObject("scripting.dictionary")
  21.     '遍历数组，2行一次
  22.     For i = LBound(arr) + 1 To UBound(arr) - 1
  23.         For j = LBound(arr, 2) To UBound(arr, 2)
  24.             '如果数据为非数字（或者为0）的情况下，则跳出本轮循环
  25.             If Not (Val(arr(i, j)) > 0 And Val(arr(i + 1, j)) > 0) Then GoTo quit
  26.             Call splitnumber(arr(i, j), dic)
  27.             Call splitnumber(arr(i + 1, j), dic)
  28.             Call AnyDic(dic)

  30.             '如果没有共同数据，则结束本轮循环，字典清空
  31.             If dic.Count = 0 Then
  32. quit:
  33.                 Check = False
  34.                 dic.RemoveAll
  35.                 Exit For
  36.             End If

  38.             arr3(j) = dic.keys
  39.             '能否进行组合的前提条件
  40.             Check = True
  41.             dic.RemoveAll
  42.         Next
  43.         If Check Then
  44.             '遍历，生成组合,x,y,z分别代表百，拾，个位
  45.             For Each x In arr3(1)
  46.                 For Each y In arr3(2)
  47.                     For Each z In arr3(3)
  48.                         '动态数组
  49.                         k = k + 1
  50.                         ReDim Preserve arr2(1 To k)
  51.                         arr2(k) = "'" & Format(x * 100 + y * 10 + z, "000")
  52.                     Next
  53.                 Next
  54.             Next
  55.         End If
  56.     Next
  57.     Columns("m").Clear
  58.     If k > 0 Then

  60.         '一维变二维，写回M列
  61.         Range("m1").Resize(k) = WorksheetFunction.Transpose(arr2)
  62.         MsgBox "提取完成"
  63.     Else
  64.         MsgBox "数据中无相同数据，组合结果为0"
  65.     End If
  66.     Set dic = Nothing

  68. End Sub

  70. Sub splitnumber(ByVal number, ByRef dic As Object)
  71. '---------------------------------------------------------------------------------------
  72. ' Procedure : splitnumber
  73. ' Author    : hwc2ycy
  74. ' Date      : 2013/1/27
  75. ' Purpose   :把数字拆分装进字典
  76. '---------------------------------------------------------------------------------------
  77. '
  78.     Dim i, s$
  79.     For i = 1 To Len(number)
  80.         s = Mid(number, i, 1)
  81.         dic(s) = dic(s) + 1
  82.     Next
  83. End Sub

  85. Sub AnyDic(ByRef dic As Object)
  86. '---------------------------------------------------------------------------------------
  87. ' Procedure : AnyDic
  88. ' Author    : hwc2ycy
  89. ' Date      : 2013/1/27
  90. ' Purpose   :分析字典，去掉没有重复数的
  91. '---------------------------------------------------------------------------------------
  92. '
  93.     Dim key
  94.     For Each key In dic.keys
  95.         If dic(key) = 1 Then dic.Remove key
  96.     Next
  97. End Sub
复制代码
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-26 21:40 , Processed in 1.026861 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表