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

Excel精英培训网

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

[已解决]求助一个问题

[复制链接]
yuio123
发表于 2012-5-6 15:49 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
想让这个VBA改成表1到表5都要运行一遍

Sub test()

    Dim ar, br, cr, dr(1 To 1000, 1 To 1)

    Dim s As String

    Dim d As Object

    Dim i As Integer, j As Integer, k As Integer

   Set d = CreateObject("scripting.dictionary")

    ar = Range("e7:cp22")

    For i = 1 To UBound(ar) Step 7

       For j = 1 To UBound(ar, 2)
            s = ""

          For k = 1 To 3

              s = s & Right((Mid(ar(i, j), k, 1) + 10 - Mid(ar(i + 1, j), k, 1)), 1)

          Next

           d(s) = d(s) + 1

     Next

    Next

    br = d.keys

    cr = d.items

    k = 0

    For i = 0 To UBound(br)

        If cr(i) > 3 Then

           k = k + 1

          dr(k, 1) = br(i)

       End If

   Next

    Range("c30:c6553").ClearContents

    Range("c30").Resize(k, 1).NumberFormatLocal = "@"

    Range("c30").Resize(k, 1) = dr

End Sub
最佳答案
月排行榜 / 总排行榜
zjdh
2012-5-6 16:57
  1. Sub sheet_5()
  2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
  3.     Dim s As String
  4.     Dim d As Object
  5.     Dim i As Integer, j As Integer, k As Integer
  6.     For M = 1 To 5
  7.         With Sheets(M)
  8.         Set d = CreateObject("scripting.dictionary")
  9.             ar = .Range("e7:cp22")
  10.             For i = 1 To UBound(ar) Step 7
  11.                 For j = 1 To UBound(ar, 2)
  12.                     s = ""
  13.                     For k = 1 To 3
  14.                        s = s & Right((Mid(ar(i, j), k, 1) + 10 - Mid(ar(i + 1, j), k, 1)), 1)
  15.                     Next
  16.                     d(s) = d(s) + 1
  17.                 Next
  18.             Next
  19.             br = d.keys
  20.             cr = d.items
  21.             k = 0
  22.             For i = 0 To UBound(br)
  23.                 If cr(i) > 3 Then
  24.                     k = k + 1
  25.                     dr(k, 1) = br(i)
  26.                 End If
  27.             Next
  28.             .Range("c30:c6553").ClearContents
  29.             .Range("c30").Resize(k, 1).NumberFormatLocal = "@"
  30.             .Range("c30").Resize(k, 1) = dr
  31.             Erase ar
  32.         End With
  33.     Next
  34. End Sub
复制代码
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
play9091
发表于 2012-5-6 15:53 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
這樣子就可以了！
  1. sub sheet_5()
  2. for I=1 to 5
  3. sheets(I).select
  4. call test
  5. end sub
复制代码
回复

使用道具 举报

yuio123
 楼主| 发表于 2012-5-6 15:56 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
play9091 发表于 2012-5-6 15:53
這樣子就可以了！

我想要把代码直接加到里面去
回复

使用道具 举报

play9091
发表于 2012-5-6 16:10 | 显示全部楼层
試試看這樣子可不可以？？
  1. sub sheet_5()
  2. Dim ar, br, cr, dr(1 To 1000, 1 To 1)
  3.      Dim s As String
  4.      Dim d As Object
  5.      Dim i As Integer, j As Integer, k As Integer
  6.     Set d = CreateObject("scripting.dictionary")
  7. for I=1 to 5
  8. sheet(I).select
  9.      ar = Range("e7:cp22")
  10.      For i = 1 To UBound(ar) Step 7
  11.         For j = 1 To UBound(ar, 2)
  12.             s = ""
  13.            For k = 1 To 3
  14.               s = s & Right((Mid(ar(i, j), k, 1) + 10 - Mid(ar(i + 1, j), k, 1)), 1)
  15.            Next
  16.             d(s) = d(s) + 1
  17.       Next
  18.      Next
  19.      br = d.keys
  20.      cr = d.items
  21.      k = 0
  22.      For i = 0 To UBound(br)
  23.          If cr(i) > 3 Then
  24.             k = k + 1
  25.            dr(k, 1) = br(i)
  26.         End If
  27.     Next
  28.      Range("c30:c6553").ClearContents
  29.      Range("c30").Resize(k, 1).NumberFormatLocal = "@"
  30.      Range("c30").Resize(k, 1) = dr
  31.      Erase ar
  32. next I
复制代码
回复

使用道具 举报

yuio123
 楼主| 发表于 2012-5-6 16:20 | 显示全部楼层
play9091 发表于 2012-5-6 16:10
試試看這樣子可不可以？？

会提示子过程或函数未定义sheet(i)
回复

使用道具 举报

zjdh
发表于 2012-5-6 16:30 | 显示全部楼层
本帖最后由 zjdh 于 2012-5-6 16:57 编辑
  1. Sub sheet_5()
  2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
  3.     Dim s As String
  4.     Dim d As Object
  5.     Dim i As Integer, j As Integer, k As Integer
  6.     For M = 1 To 5
  7.         With Sheets(M)
  8.         Set d = CreateObject("scripting.dictionary")
  9.             ar = .Range("e7:cp22")
  10.             For i = 1 To UBound(ar) Step 7
  11.                 For j = 1 To UBound(ar, 2)
  12.                     s = ""
  13.                     For k = 1 To 3
  14.                        s = s & Right((Mid(ar(i, j), k, 1) + 10 - Mid(ar(i + 1, j), k, 1)), 1)
  15.                     Next
  16.                     d(s) = d(s) + 1
  17.                 Next
  18.             Next
  19.             br = d.keys
  20.             cr = d.items
  21.             k = 0
  22.             For i = 0 To UBound(br)
  23.                 If cr(i) > 3 Then
  24.                     k = k + 1
  25.                     dr(k, 1) = br(i)
  26.                 End If
  27.             Next
  28.             .Range("c30:c6553").ClearContents
  29.             .Range("c30").Resize(k, 1).NumberFormatLocal = "@"
  30.             .Range("c30").Resize(k, 1) = dr
  31.             Erase ar
  32.         End With
  33.     Next
  34. End Sub
复制代码
回复

使用道具 举报

yuio123
 楼主| 发表于 2012-5-6 16:42 | 显示全部楼层
zjdh 发表于 2012-5-6 16:30

只有表1的结果正确,
回复

使用道具 举报

zjdh
发表于 2012-5-6 16:57 | 显示全部楼层    本楼为最佳答案   
  1. Sub sheet_5()
  2.     Dim ar, br, cr, dr(1 To 1000, 1 To 1)
  3.     Dim s As String
  4.     Dim d As Object
  5.     Dim i As Integer, j As Integer, k As Integer
  6.     For M = 1 To 5
  7.         With Sheets(M)
  8.         Set d = CreateObject("scripting.dictionary")
  9.             ar = .Range("e7:cp22")
  10.             For i = 1 To UBound(ar) Step 7
  11.                 For j = 1 To UBound(ar, 2)
  12.                     s = ""
  13.                     For k = 1 To 3
  14.                        s = s & Right((Mid(ar(i, j), k, 1) + 10 - Mid(ar(i + 1, j), k, 1)), 1)
  15.                     Next
  16.                     d(s) = d(s) + 1
  17.                 Next
  18.             Next
  19.             br = d.keys
  20.             cr = d.items
  21.             k = 0
  22.             For i = 0 To UBound(br)
  23.                 If cr(i) > 3 Then
  24.                     k = k + 1
  25.                     dr(k, 1) = br(i)
  26.                 End If
  27.             Next
  28.             .Range("c30:c6553").ClearContents
  29.             .Range("c30").Resize(k, 1).NumberFormatLocal = "@"
  30.             .Range("c30").Resize(k, 1) = dr
  31.             Erase ar
  32.         End With
  33.     Next
  34. End Sub
复制代码
回复

使用道具 举报

play9091
发表于 2012-5-6 17:29 | 显示全部楼层
喔！忘了加"s"，sheets(i)
最佳又離我而去了！哭！

点评

windimi007
辛苦分哈！继续加油！  发表于 2012-5-6 17:30

评分

参与人数 1 +18 收起 理由
windimi007 + 18 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2012-5-6 17:30 | 显示全部楼层
  1. 01.Sub sheet_5()

  3. 02.    Dim ar, br, cr, dr(1 To 1000, 1 To 1)

  5. 03.    Dim s As String

  7. 04.    Dim d As Object

  9. 05.    Dim i As Integer, j
复制代码
回复

使用道具 举报

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

本版积分规则

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

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

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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