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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 请老师编写代码
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 2304|回复: 10

[已解决]请老师编写代码

[复制链接]
ymq123
发表于 2013-3-31 10:55 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请老师编写代码。谢谢！
最佳答案
月排行榜 / 总排行榜
无聊的疯子
2013-3-31 11:22
这样的？？

  2. Private Sub CommandButton1_Click()
  3. Dim D As Object, Arr(), Brr(), Crr(), Drr(), Ar() As String, S As String
  4. Dim Hx As Long, Xt As Long, Bt As Long, Lx As Long
  5.     Set D = CreateObject("Scripting.dictionary")
  6.     Arr = Range("A2:H23").Value
  7.     For Hx = 1 To UBound(Arr)
  8.         For Lx = 1 To UBound(Arr, 2)
  9.             S = S & "-" & Arr(Hx, Lx)
  10.         Next
  11.         D(S) = D(S) + 1
  12.         S = ""
  13.     Next
  14.    
  15.     Brr = D.items
  16.     ReDim Crr(1 To UBound(Brr) + 1, 1 To UBound(Arr, 2))
  17.     ReDim Drr(1 To UBound(Brr) + 1, 1 To UBound(Arr, 2))
  18.     Arr = D.keys
  19.     For Hx = 0 To UBound(Brr)
  20.         If Brr(Hx) = 1 Then
  21.             Xt = Xt + 1
  22.             Ar = Split(Arr(Hx), "-")
  23.             For Lx = 1 To UBound(Ar) - 1
  24.                 Crr(Xt, Lx) = Ar(Lx)
  25.             Next
  26.         Else
  27.             Bt = Bt + 1
  28.             Ar = Split(Arr(Hx), "-")
  29.             For Lx = 1 To UBound(Ar) - 1
  30.                 Drr(Bt, Lx) = Ar(Lx)
  31.             Next
  32.         End If
  33.     Next
  34.     Range("J2:Y100").ClearContents
  35.     Range("J2").Resize(Xt, UBound(Crr, 2)).Value = Crr
  36.     Range("S2").Resize(Bt, UBound(Drr, 2)).Value = Drr
  37. End Sub
复制代码

提取表格中数字相同或不同的行.rar

10.57 KB, 下载次数: 25
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-3-31 11:04 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
这个不是写过类似的嘛。
回复

使用道具 举报

ymq123
 楼主| 发表于 2013-3-31 11:18 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
hwc2ycy 发表于 2013-3-31 11:04
这个不是写过类似的嘛。

这是在一个表里选取不相同数字行或相同数字行，那是在二个表里进行操作，我也试套用原来的代码没有做好，再麻烦你一次，谢谢！
回复

使用道具 举报

发表于 2013-3-31 11:22 | 显示全部楼层    本楼为最佳答案   
这样的？？

  2. Private Sub CommandButton1_Click()
  3. Dim D As Object, Arr(), Brr(), Crr(), Drr(), Ar() As String, S As String
  4. Dim Hx As Long, Xt As Long, Bt As Long, Lx As Long
  5.     Set D = CreateObject("Scripting.dictionary")
  6.     Arr = Range("A2:H23").Value
  7.     For Hx = 1 To UBound(Arr)
  8.         For Lx = 1 To UBound(Arr, 2)
  9.             S = S & "-" & Arr(Hx, Lx)
  10.         Next
  11.         D(S) = D(S) + 1
  12.         S = ""
  13.     Next
  14.    
  15.     Brr = D.items
  16.     ReDim Crr(1 To UBound(Brr) + 1, 1 To UBound(Arr, 2))
  17.     ReDim Drr(1 To UBound(Brr) + 1, 1 To UBound(Arr, 2))
  18.     Arr = D.keys
  19.     For Hx = 0 To UBound(Brr)
  20.         If Brr(Hx) = 1 Then
  21.             Xt = Xt + 1
  22.             Ar = Split(Arr(Hx), "-")
  23.             For Lx = 1 To UBound(Ar) - 1
  24.                 Crr(Xt, Lx) = Ar(Lx)
  25.             Next
  26.         Else
  27.             Bt = Bt + 1
  28.             Ar = Split(Arr(Hx), "-")
  29.             For Lx = 1 To UBound(Ar) - 1
  30.                 Drr(Bt, Lx) = Ar(Lx)
  31.             Next
  32.         End If
  33.     Next
  34.     Range("J2:Y100").ClearContents
  35.     Range("J2").Resize(Xt, UBound(Crr, 2)).Value = Crr
  36.     Range("S2").Resize(Bt, UBound(Drr, 2)).Value = Drr
  37. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
ymq123 + 3

查看全部评分

回复

使用道具 举报

ymq123
 楼主| 发表于 2013-3-31 11:32 | 显示全部楼层
无聊的疯子 发表于 2013-3-31 11:22
这样的？？

不好意思，还要麻烦你，请把选取相同和不同的代码分开编写。谢谢
回复

使用道具 举报

hwc2ycy
发表于 2013-3-31 11:33 | 显示全部楼层
  1. Private Sub CommandButton1_Click()
  2.     Dim arr, arrtemp
  3.     Dim rg As Range

  5.     On Error Resume Next

  7.     Set rg = Range("a2:g23").SpecialCells(xlCellTypeBlanks)
  8.     If Not rg Is Nothing Then rg = " "
  9.     arr = Range("a2:g23")
  10.     Set rg = Nothing
  11.     Dim dic As Object, str$
  12.     Set dic = CreateObject("scripting.dictionary")

  14.     For i = LBound(arr) To UBound(arr)
  15.         str = Join(WorksheetFunction.Index(arr, i, 0), "#")
  16.         dic(str) = dic(str) + 1
  17.     Next
  18.     arr = arrGet(dic, False)
  19.     If IsArray(arr) Then Range("s2").Resize(UBound(arr), UBound(arr, 2)) = arr
  20. End Sub

  22. Function arrGet(dic As Object, Optional isIn As Boolean = False)
  23. 'isIn为FALSE 提取非重复值
  24. 'isIn为TRUE，提取重复值
  25.     Dim arr()
  26.     Dim arrtemp
  27.     If dic.Count = 0 Then arrGet = False: Exit Function

  29.     Dim lCount As Long
  30.     Dim keys
  31.     For Each keys In dic.keys
  32.         If dic(keys) > 1 Then dic.Key(keys) = keys & "/"
  33.     Next
  34.     arrtemp = Filter(dic.keys, "/", isIn)
  35.     If UBound(arrtemp) = -1 Then arrGet = False: Exit Function

  37.     ReDim arr(1 To UBound(arrtemp) + 1)
  38.     Dim str$
  39.     For i = LBound(arr) To UBound(arr)
  40.         str = Replace(arrtemp(i - 1), "/", "")
  41.         arr(i) = Split(str, "#")
  42.     Next
  43.     arrGet = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
  44. End Function
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-3-31 11:34 | 显示全部楼层
要提取重复值还是非重复值，只要改下arrget的第2个参数即可。
回复

使用道具 举报

发表于 2013-3-31 11:38 | 显示全部楼层
ymq123 发表于 2013-3-31 11:32
不好意思，还要麻烦你，请把选取相同和不同的代码分开编写。谢谢

要做成两段代码？？由你自己选择 相同或者不同？
回复

使用道具 举报

hwc2ycy
发表于 2013-3-31 11:40 | 显示全部楼层
  1. Private Sub CommandButton1_Click()
  2.     Dim arr, arrtemp
  3.     Dim rg As Range

  5.     On Error Resume Next

  7.     Set rg = Range("a2:g23").SpecialCells(xlCellTypeBlanks)
  8.     If Not rg Is Nothing Then rg = " "
  9.     arr = Range("a2:g23")
  10.     Set rg = Nothing
  11.     Dim dic As Object, str$
  12.     Set dic = CreateObject("scripting.dictionary")

  14.     For i = LBound(arr) To UBound(arr)
  15.         str = Join(WorksheetFunction.Index(arr, i, 0), "#")
  16.         dic(str) = dic(str) + 1
  17.     Next
  18.     Application.ScreenUpdating = False
  19.    
  20.     '提取非重复值
  21.     arr = arrGet(dic, False)
  22.     If IsArray(arr) Then Range("s2").Resize(UBound(arr), UBound(arr, 2)) = arr
  23.    
  24.     '提取重复值
  25.     arr = arrGet(dic, True)
  26.     If IsArray(arr) Then Range("aa2").Resize(UBound(arr), UBound(arr, 2)) = arr
  27.     Application.ScreenUpdating = True
  28. End Sub

  30. Function arrGet(dic As Object, Optional isIn As Boolean = False)
  31. 'isIn为FALSE 提取非重复值
  32. 'isIn为TRUE，提取重复值
  33.     Dim arr()
  34.     Dim arrtemp
  35.     If dic.Count = 0 Then arrGet = False: Exit Function

  37.     Dim lCount As Long
  38.     Dim keys
  39.     For Each keys In dic.keys
  40.         If dic(keys) > 1 Then dic.Key(keys) = keys & "/"
  41.     Next
  42.     arrtemp = Filter(dic.keys, "/", isIn)
  43.     If UBound(arrtemp) = -1 Then arrGet = False: Exit Function

  45.     ReDim arr(1 To UBound(arrtemp) + 1)
  46.     Dim str$
  47.     For i = LBound(arr) To UBound(arr)
  48.         str = Replace(arrtemp(i - 1), "/", "")
  49.         arr(i) = Split(str, "#")
  50.     Next
  51.     arrGet = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
  52. End Function
复制代码
回复

使用道具 举报

发表于 2013-3-31 11:56 | 显示全部楼层
ymq123 发表于 2013-3-31 11:32
不好意思，还要麻烦你，请把选取相同和不同的代码分开编写。谢谢



把代码写成一个公用过程，直接调用 就行了，
参数说明，
第一个参数为数据源区域，
第二个参数为 相同或者不同，true 为相同，false 为不同
第三个参数为 数据写入的目标单元格

按钮里用调用了2次，第一次处理相同，第二次处理不同

  2. Private Sub CommandButton1_Click()
  3.     Range("J2:P100").ClearContents
  4.     ChuLi Range("A2:H23"), True, Range("J2")
  5.     Range("S2:Y100").ClearContents
  6.     ChuLi Range("A2:H23"), False, Range("S2")
  7. End Sub
  8. Private Sub ChuLi(ByVal DaYuan As Range, ByVal Xt As Boolean, ByVal MuBiao As Range)
  9. Dim D As Object, Arr(), Brr(), Crr(), Drr(), Ar() As String, S As String
  10. Dim Hx As Long, X As Long, Lx As Long
  11.     Set D = CreateObject("Scripting.dictionary")
  12.     Arr = Range("A2:H23").Value
  13.     For Hx = 1 To UBound(Arr)
  14.         For Lx = 1 To UBound(Arr, 2)
  15.             S = S & "-" & Arr(Hx, Lx)
  16.         Next
  17.         D(S) = D(S) + 1
  18.         S = ""
  19.     Next
  20.     Brr = D.items
  21.     ReDim Crr(1 To UBound(Brr) + 1, 1 To UBound(Arr, 2))
  22.     Arr = D.keys
  23.     If Xt Then
  24.         For Hx = 0 To UBound(Brr)
  25.             If Brr(Hx) = 1 Then
  26.                 X = X + 1
  27.                 Ar = Split(Arr(Hx), "-")
  28.                 For Lx = 1 To UBound(Ar) - 1
  29.                     Crr(X, Lx) = Ar(Lx)
  30.                 Next
  31.             End If
  32.         Next
  33.     Else
  34.         For Hx = 0 To UBound(Brr)
  35.             If Brr(Hx) > 1 Then
  36.                 X = X + 1
  37.                 Ar = Split(Arr(Hx), "-")
  38.                 For Lx = 1 To UBound(Ar) - 1
  39.                     Crr(X, Lx) = Ar(Lx)
  40.                 Next
  41.             End If
  42.         Next
  43.     End If
  44.     MuBiao.Resize(X, UBound(Crr, 2)).Value = Crr
  45. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-7 14:57 , Processed in 0.345384 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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