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

Excel精英培训网

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

[已解决]请修改代码

[复制链接]
ymq123
发表于 2014-4-27 17:38 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
你好，
我把刚才的题目改了一下，筛选结果不正常，现在把改过的发给你，请修改。
谢谢！
最佳答案
月排行榜 / 总排行榜
dsmch
2014-4-27 19:09
  1. Sub Macro1()
  2. Dim arr, brr, ar, br, d, d2, y%
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. For y = 0 To 2
  6. For k = 1 To 229 Step 114
  7.     arr = Sheets("1").Cells(k, y * 14 + 1).Resize(56, 9)
  8.     brr = Sheets("1").Cells(k + 57, y * 14 + 1).Resize(56, 9)
  9.     For i = 1 To UBound(arr)
  10.         zf = Join(Application.Index(arr, i, 0), ",")
  11.         d(zf) = d(zf) + 1
  12.         d2(zf & "," & d(zf)) = i
  13.     Next
  14.     d.RemoveAll
  15.     For i = 1 To UBound(brr)
  16.         zf = Join(Application.Index(brr, i, 0), ",")
  17.         d(zf) = d(zf) + 1
  18.         If d2.exists(zf & "," & d(zf)) Then
  19.             For j = 1 To UBound(brr, 2)
  20.                 brr(i, j) = ""
  21.                 arr(d2(zf & "," & d(zf)), j) = ""
  22.             Next
  23.         End If
  24.     Next
  25.     ReDim ar(1 To 56, 1 To 9)
  26.     ReDim br(1 To 56, 1 To 9)
  27.     s = 0
  28.     For i1 = 1 To UBound(arr)
  29.      zf = Join(Application.Index(arr, i1, 0), ",")
  30.      If zf <> String(8, ",") Then
  31.         s = s + 1
  32.         For j1 = 1 To UBound(arr, 2)
  33.             ar(s, j1) = arr(i1, j1)
  34.         Next
  35.      End If
  36.     Next
  37.     s2 = 0
  38.     For i2 = 1 To UBound(brr)
  39.      zf = Join(Application.Index(brr, i2, 0), ",")
  40.      If zf <> String(8, ",") Then
  41.         s2 = s2 + 1
  42.         For j2 = 1 To UBound(brr, 2)
  43.             br(s2, j2) = brr(i2, j2)
  44.         Next
  45.      End If
  46.     Next
  47.     Sheets("2").Cells(k, 1 + 14 * y).Resize(56, 9) = ar
  48.     Sheets("2").Cells(k + 57, 1 + 14 * y).Resize(56, 9) = br
  49.     d.RemoveAll
  50.     d2.RemoveAll
  51. Next
  52. Next
  53. End Sub
复制代码

删除表格中相同数字的行 .rar

30.13 KB, 下载次数: 5
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
dsmch
发表于 2014-4-27 17:57 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub Macro1()
  2. Dim arr, brr, d, d2, y%
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. For y = 0 To 2
  6. For k = 1 To 229 Step 114
  7.     arr = Sheets("1").Cells(k, y * 14 + 1).Resize(56, 9)
  8.     brr = Sheets("1").Cells(k + 57, y * 14 + 1).Resize(56, 9)
  9.     For i = 1 To UBound(arr)
  10.         zf = Join(Application.Index(arr, i, 0), ",")
  11.         d(zf) = d(zf) + 1
  12.         d2(zf & "," & d(zf)) = i
  13.     Next
  14.     d.RemoveAll
  15.     For i = 1 To UBound(brr)
  16.         zf = Join(Application.Index(brr, i, 0), ",")
  17.         d(zf) = d(zf) + 1
  18.         If d2.exists(zf & "," & d(zf)) Then
  19.             For j = 1 To UBound(brr, 2)
  20.                 brr(i, j) = ""
  21.                 arr(d2(zf & "," & d(zf)), j) = ""
  22.             Next
  23.         End If
  24.     Next
  25.     Sheets("2").Cells(k, 1 + 14 * y).Resize(56, 9) = arr
  26.     Sheets("2").Cells(k + 57, 1 + 14 * y).Resize(56, 9) = brr
  27.     d.RemoveAll
  28.     d2.RemoveAll
  29. Next
  30. Next
  31. End Sub
复制代码
回复

使用道具 举报

dsmch
发表于 2014-4-27 18:01 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
………………

删除表格中相同数字的行.zip

48.4 KB, 下载次数: 8
回复

使用道具 举报

dsmch
发表于 2014-4-27 19:09 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. Dim arr, brr, ar, br, d, d2, y%
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. For y = 0 To 2
  6. For k = 1 To 229 Step 114
  7.     arr = Sheets("1").Cells(k, y * 14 + 1).Resize(56, 9)
  8.     brr = Sheets("1").Cells(k + 57, y * 14 + 1).Resize(56, 9)
  9.     For i = 1 To UBound(arr)
  10.         zf = Join(Application.Index(arr, i, 0), ",")
  11.         d(zf) = d(zf) + 1
  12.         d2(zf & "," & d(zf)) = i
  13.     Next
  14.     d.RemoveAll
  15.     For i = 1 To UBound(brr)
  16.         zf = Join(Application.Index(brr, i, 0), ",")
  17.         d(zf) = d(zf) + 1
  18.         If d2.exists(zf & "," & d(zf)) Then
  19.             For j = 1 To UBound(brr, 2)
  20.                 brr(i, j) = ""
  21.                 arr(d2(zf & "," & d(zf)), j) = ""
  22.             Next
  23.         End If
  24.     Next
  25.     ReDim ar(1 To 56, 1 To 9)
  26.     ReDim br(1 To 56, 1 To 9)
  27.     s = 0
  28.     For i1 = 1 To UBound(arr)
  29.      zf = Join(Application.Index(arr, i1, 0), ",")
  30.      If zf <> String(8, ",") Then
  31.         s = s + 1
  32.         For j1 = 1 To UBound(arr, 2)
  33.             ar(s, j1) = arr(i1, j1)
  34.         Next
  35.      End If
  36.     Next
  37.     s2 = 0
  38.     For i2 = 1 To UBound(brr)
  39.      zf = Join(Application.Index(brr, i2, 0), ",")
  40.      If zf <> String(8, ",") Then
  41.         s2 = s2 + 1
  42.         For j2 = 1 To UBound(brr, 2)
  43.             br(s2, j2) = brr(i2, j2)
  44.         Next
  45.      End If
  46.     Next
  47.     Sheets("2").Cells(k, 1 + 14 * y).Resize(56, 9) = ar
  48.     Sheets("2").Cells(k + 57, 1 + 14 * y).Resize(56, 9) = br
  49.     d.RemoveAll
  50.     d2.RemoveAll
  51. Next
  52. Next
  53. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-19 06:59 , Processed in 0.287284 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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