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

Excel精英培训网

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

[已解决]请老师修改代码

[复制链接]
ymq123
发表于 2014-4-27 12:10 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请老师修改代码
       1、筛选出工作表1表格1和表格2不相同数字的行、表格3和表格4不相同数字的行，相同数字的行删除。筛选结果分别放在工作表2各表格里，在工作表1中，表格1筛选出来的结果放到工作表2表格5中；表格2筛选出来的结果放到工作表2表格6中；表格3筛选出来的结果放到工作表2表格7中；表格4筛选出来的结果放到工作表2表格8中.
      2、红字是相同数字的行，即要删除的行
      3、筛选结果如工作表2各表格
谢谢！
最佳答案
月排行榜 / 总排行榜
dsmch
2014-4-27 15:34
  1. Sub Macro1()
  2. Dim arr, brr, ar, br, d, d2
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. For k = 1 To 13 Step 12
  6.     arr = Sheet1.Cells(k, 1).Resize(5, 8)
  7.     brr = Sheet1.Cells(k + 6, 1).Resize(5, 8)
  8.     For i = 1 To UBound(arr)
  9.         zf = Join(Application.Index(arr, i, 0), ",")
  10.         d(zf) = d(zf) + 1
  11.         d2(zf & "," & d(zf)) = i
  12.     Next
  13.     d.RemoveAll
  14.     For i = 1 To UBound(brr)
  15.         zf = Join(Application.Index(brr, i, 0), ",")
  16.         d(zf) = d(zf) + 1
  17.         If d2.exists(zf & "," & d(zf)) Then
  18.             For j = 1 To UBound(brr, 2)
  19.                 brr(i, j) = ""
  20.                 arr(d2(zf & "," & d(zf)), j) = ""
  21.             Next
  22.         End If
  23.     Next
  24.     ReDim ar(1 To 5, 1 To 8)
  25.     ReDim br(1 To 5, 1 To 8)
  26.     s = 0
  27.     For i1 = 1 To UBound(arr)
  28.      zf = Join(Application.Index(arr, i1, 0), ",")
  29.      If zf <> String(7, ",") Then
  30.         s = s + 1
  31.         For j1 = 1 To UBound(arr, 2)
  32.             ar(s, j1) = arr(i1, j1)
  33.         Next
  34.      End If
  35.     Next
  36.     s2 = 0
  37.     For i2 = 1 To UBound(brr)
  38.      zf = Join(Application.Index(brr, i2, 0), ",")
  39.      If zf <> String(7, ",") Then
  40.         s2 = s2 + 1
  41.         For j2 = 1 To UBound(brr, 2)
  42.             br(s2, j2) = brr(i2, j2)
  43.         Next
  44.      End If
  45.     Next
  46.     Sheet2.Cells(k, 1).Resize(5, 8) = ar
  47.     Sheet2.Cells(k + 6, 1).Resize(5, 8) = br
  48.     d.RemoveAll
  49.     d2.RemoveAll
  50.     Erase ar: Erase br
  51. Next
  52. End Sub
复制代码

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

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

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
dsmch
发表于 2014-4-27 15:34 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub Macro1()
  2. Dim arr, brr, ar, br, d, d2
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. For k = 1 To 13 Step 12
  6.     arr = Sheet1.Cells(k, 1).Resize(5, 8)
  7.     brr = Sheet1.Cells(k + 6, 1).Resize(5, 8)
  8.     For i = 1 To UBound(arr)
  9.         zf = Join(Application.Index(arr, i, 0), ",")
  10.         d(zf) = d(zf) + 1
  11.         d2(zf & "," & d(zf)) = i
  12.     Next
  13.     d.RemoveAll
  14.     For i = 1 To UBound(brr)
  15.         zf = Join(Application.Index(brr, i, 0), ",")
  16.         d(zf) = d(zf) + 1
  17.         If d2.exists(zf & "," & d(zf)) Then
  18.             For j = 1 To UBound(brr, 2)
  19.                 brr(i, j) = ""
  20.                 arr(d2(zf & "," & d(zf)), j) = ""
  21.             Next
  22.         End If
  23.     Next
  24.     ReDim ar(1 To 5, 1 To 8)
  25.     ReDim br(1 To 5, 1 To 8)
  26.     s = 0
  27.     For i1 = 1 To UBound(arr)
  28.      zf = Join(Application.Index(arr, i1, 0), ",")
  29.      If zf <> String(7, ",") Then
  30.         s = s + 1
  31.         For j1 = 1 To UBound(arr, 2)
  32.             ar(s, j1) = arr(i1, j1)
  33.         Next
  34.      End If
  35.     Next
  36.     s2 = 0
  37.     For i2 = 1 To UBound(brr)
  38.      zf = Join(Application.Index(brr, i2, 0), ",")
  39.      If zf <> String(7, ",") Then
  40.         s2 = s2 + 1
  41.         For j2 = 1 To UBound(brr, 2)
  42.             br(s2, j2) = brr(i2, j2)
  43.         Next
  44.      End If
  45.     Next
  46.     Sheet2.Cells(k, 1).Resize(5, 8) = ar
  47.     Sheet2.Cells(k + 6, 1).Resize(5, 8) = br
  48.     d.RemoveAll
  49.     d2.RemoveAll
  50.     Erase ar: Erase br
  51. Next
  52. End Sub
复制代码
回复

使用道具 举报

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

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

13.63 KB, 下载次数: 10
回复

使用道具 举报

ymq123
 楼主| 发表于 2014-4-27 16:53 | 显示全部楼层
dsmch 发表于 2014-4-27 15:34

If zf <> String(7, ",") Then
请问此句代码中7是什么意思？
谢谢！

点评

dsmch
如果一行为空，每行8列，中间用"，"连接，生成7个重复的","  发表于 2014-4-27 16:58
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-27 03:26 , Processed in 0.581243 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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