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

Excel精英培训网

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

[已解决]较复杂的数据录入

[复制链接]
sparkguo
发表于 2013-5-26 14:28 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
对象所在单元格（可能是合并单元格）录入连续的数字

谢谢大侠了
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2013-5-26 15:12
本帖最后由 hwc2ycy 于 2013-5-26 15:32 编辑

字典法，效率高。
  1. Sub 入口()
  2.     Dim objRg As Range
  3.     Dim rg As Range
  4.     Dim lCount As Long

  6.     On Error Resume Next

  8.     '强制选择单元格区域
  9.     Do
  10.         Set objRg = Application.InputBox(prompt:="请选择要编号的对象所在的单元格区域", Title:="给指定单元格区域内的对象重新编号", Type:=8)
  11.         Err.Clear
  12.     Loop Until Not objRg Is Nothing

  14.     On Error GoTo ErrorHandler
  15.     '关闭屏幕更新，警告，事件
  16.     Application.ScreenUpdating = False
  17.     Application.DisplayAlerts = False
  18.     Application.EnableEvents = False

  20.     '字典
  21.     Dim objDic As Object
  22.     Set objDic = CreateObject("scripting.dictionary")

  24.     '添加地址
  25.     Dim objShape As Shape
  26.     For Each objShape In ActiveSheet.Shapes
  27.         objDic(objShape.TopLeftCell.Address(False, False)) = ""
  28.     Next

  30.     '找对像
  31.     For Each rg In objRg
  32.         If objDic.exists(rg.Address(False, False)) Then
  33.             lCount = lCount + 1
  34.             rg.Value = lCount
  35.         End If
  36.     Next

  38.     '信息提示
  39.     If lCount > 0 Then
  40.         MsgBox "一共找到了 " & lCount & " 个对象"
  41.     Else
  42.         MsgBox objRg.Address(False, False) & "区域内无对象"
  43.     End If

  45.     Application.ScreenUpdating = True
  46.     Application.DisplayAlerts = True
  47.     Application.EnableEvents = True
  48.     Set objDic = Nothing
  49.     Exit Sub

  51. ErrorHandler:
  52.     MsgBox Err.Number & vbCrLf & _
  53.            Err.Description
  54.     Application.ScreenUpdating = True
  55.     Application.DisplayAlerts = True
  56.     Application.EnableEvents = True
  57. End Sub
复制代码

求助.rar

118.6 KB, 下载次数: 23
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-5-26 14:56 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 hwc2ycy 于 2013-5-26 15:31 编辑
  1. Function hasShape(strRG As String) As Boolean
  2.     On Error GoTo ErrorHandler
  3.     Dim objShape As Shape
  4.     For Each objShape In ActiveSheet.Shapes
  5.         If objShape.TopLeftCell.Address(False, False) = Range(strRG).Address(False, False) Then
  6.             hasShape = True
  7.             Exit Function
  8.         End If
  9.     Next
  10. ErrorHandler:
  11. End Function

  13. Sub 入口()
  14.     Dim objRg As Range
  15.     Dim rg As Range
  16.     Dim lCount As Long

  18.     On Error Resume Next

  20.     Do
  21.         Set objRg = Application.InputBox(prompt:="请选择要删除对象的单元格区域", Title:="删除指定单元格区域内的对象", Type:=8)
  22.         Err.Clear
  23.     Loop Until Not objRg Is Nothing

  25.     On Error GoTo ErrorHandler

  27.     Application.ScreenUpdating = False
  28.     Application.DisplayAlerts = False
  29.     Application.EnableEvents = False


  32.     For Each rg In objRg
  33.         If hasShape(rg.Address) Then
  34.             lCount = lCount + 1
  35.             rg.Value = lCount
  36.         End If
  37.     Next
  38.     If lCount > 0 Then
  39.         MsgBox "一共找到了 " & lCount & " 个对象"
  40.     Else
  41.         MsgBox objRg.Address(False, False) & "区域内无对象"
  42.     End If
  43.     Application.ScreenUpdating = True
  44.     Application.DisplayAlerts = True
  45.     Application.EnableEvents = True
  46.     Exit Sub

  48. ErrorHandler:
  49.     MsgBox Err.Number & vbCrLf & _
  50.            Err.Description
  51.     Application.ScreenUpdating = True
  52.     Application.DisplayAlerts = True
  53.     Application.EnableEvents = True
  54. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-5-26 14:58 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 hwc2ycy 于 2013-5-26 15:31 编辑

对话框的提示没改，
  1. Sub 入口()
  2.     Dim objRg As Range
  3.     Dim rg As Range
  4.     Dim lCount As Long

  6.     On Error Resume Next

  8.     Do
  9.         Set objRg = Application.InputBox(prompt:="请选择要编号的对象所在的单元格区域", Title:="给指定单元格区域内的对象重新编号", Type:=8)
  10.         Err.Clear
  11.     Loop Until Not objRg Is Nothing

  13.     On Error GoTo ErrorHandler

  15.     Application.ScreenUpdating = False
  16.     Application.DisplayAlerts = False
  17.     Application.EnableEvents = False


  20.     For Each rg In objRg
  21.         If hasShape(rg.Address) Then
  22.             lCount = lCount + 1
  23.             rg.Value = lCount
  24.         End If
  25.     Next
  26.     If lCount > 0 Then
  27.         MsgBox "一共找到了 " & lCount & " 个对象"
  28.     Else
  29.         MsgBox objRg.Address(False, False) & "区域内无对象"
  30.     End If
  31.     Application.ScreenUpdating = True
  32.     Application.DisplayAlerts = True
  33.     Application.EnableEvents = True
  34.     Exit Sub

  36. ErrorHandler:
  37.     MsgBox Err.Number & vbCrLf & _
  38.            Err.Description
  39.     Application.ScreenUpdating = True
  40.     Application.DisplayAlerts = True
  41.     Application.EnableEvents = True
  42. End Sub
复制代码
回复

使用道具 举报

sparkguo
 楼主| 发表于 2013-5-26 15:00 | 显示全部楼层
hwc2ycy 发表于 2013-5-26 14:58
对话框的提示没改，

老师  运行提示子过程或函数未定义？
可否放在附件中
回复

使用道具 举报

hwc2ycy
发表于 2013-5-26 15:02 | 显示全部楼层
给对像编号.rar (127.11 KB, 下载次数: 40)
回复

使用道具 举报

hwc2ycy
发表于 2013-5-26 15:05 | 显示全部楼层
其实如果用到字典，效率会更高，
回复

使用道具 举报

sparkguo
 楼主| 发表于 2013-5-26 15:11 | 显示全部楼层
hwc2ycy 发表于 2013-5-26 15:02

  •   If hasShape(rg.Address) Then
  •             Debug.Print rg.Address(False, False) & " has shape"
老师以上两句是什么意思
回复

使用道具 举报

hwc2ycy
发表于 2013-5-26 15:12 | 显示全部楼层    本楼为最佳答案   
本帖最后由 hwc2ycy 于 2013-5-26 15:32 编辑

字典法，效率高。
  1. Sub 入口()
  2.     Dim objRg As Range
  3.     Dim rg As Range
  4.     Dim lCount As Long

  6.     On Error Resume Next

  8.     '强制选择单元格区域
  9.     Do
  10.         Set objRg = Application.InputBox(prompt:="请选择要编号的对象所在的单元格区域", Title:="给指定单元格区域内的对象重新编号", Type:=8)
  11.         Err.Clear
  12.     Loop Until Not objRg Is Nothing

  14.     On Error GoTo ErrorHandler
  15.     '关闭屏幕更新，警告，事件
  16.     Application.ScreenUpdating = False
  17.     Application.DisplayAlerts = False
  18.     Application.EnableEvents = False

  20.     '字典
  21.     Dim objDic As Object
  22.     Set objDic = CreateObject("scripting.dictionary")

  24.     '添加地址
  25.     Dim objShape As Shape
  26.     For Each objShape In ActiveSheet.Shapes
  27.         objDic(objShape.TopLeftCell.Address(False, False)) = ""
  28.     Next

  30.     '找对像
  31.     For Each rg In objRg
  32.         If objDic.exists(rg.Address(False, False)) Then
  33.             lCount = lCount + 1
  34.             rg.Value = lCount
  35.         End If
  36.     Next

  38.     '信息提示
  39.     If lCount > 0 Then
  40.         MsgBox "一共找到了 " & lCount & " 个对象"
  41.     Else
  42.         MsgBox objRg.Address(False, False) & "区域内无对象"
  43.     End If

  45.     Application.ScreenUpdating = True
  46.     Application.DisplayAlerts = True
  47.     Application.EnableEvents = True
  48.     Set objDic = Nothing
  49.     Exit Sub

  51. ErrorHandler:
  52.     MsgBox Err.Number & vbCrLf & _
  53.            Err.Description
  54.     Application.ScreenUpdating = True
  55.     Application.DisplayAlerts = True
  56.     Application.EnableEvents = True
  57. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-5-26 15:15 | 显示全部楼层
sparkguo 发表于 2013-5-26 15:11
  •   If hasShape(rg.Address) Then
  •             Debug.Print rg.Address(False, False) & " has s ...

    • 自定义函数，检测单元格是否有对象。
    如果有，就打印出信息，
    这个是调试用的，我刚没删除。
    回复

    使用道具 举报

    发表于 2013-5-27 20:56 | 显示全部楼层
    来学习的                       
    回复

    使用道具 举报

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

    本版积分规则

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

    GMT+8, 2024-4-27 08:48 , Processed in 0.343539 second(s), 10 queries , Gzip On, Yac On.

    Powered by Discuz! X3.4

    Copyright © 2001-2020, Tencent Cloud.

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