vba运行过程中判断

功能建议 · 193 次浏览
修心a 创建于 2022-06-14 13:04

有些VBA在代码在编写的时候考虑功能友好化(或者人机交互友好)会用一些可以让用户输入信息的框(InputBox)但是我在使用您的动作时发现有信息输入框的代码动作会默认填零跳过而不让用户输入,从而导致程序运行结果与预计结果不一致(VBA不用动作单独运行时结果与预期结果一致)

还有一个问题,就是在使用的时候有时候会不删除新建的VBA模块,而停留在VBA窗口下打开对应的模块

以上问题使用软件时office2019出现的

涉及代码:涉及多个代码,一些时两个问题都有的代码(代码来源于孙兴华老师的分享)

Sub SplitShts()
    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range, aRef, strYesOrNo As String
    Dim strKey As String, strTemp As String
    On Error Resume Next '忽略错误,程序继续运行
    Set d = CreateObject("scripting.dictionary")
    Set rngGist = Application.InputBox("请框选拆分依据列!只能选择单列单元格区域!", Title:="提示",Default:=1, Type:=8)
    '用户选择的拆分依据列
    lngGistCol = rngGist.Column
    '拆分依据列的列标
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数?", Default:=1))
    '用户设置总表的标题行数
    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数,程序退出。": Exit Sub
    strYesOrNo = MsgBox("是否需要在分表保留总表格式?", vbYesNo)
    Set rngData = rngGist.Parent.UsedRange
    '总表的数据区域
    Set rngFormat = rngGist.Parent.Cells
    '总表的单元格区域用于粘贴总表格式
    aData = rngData.Value '数据源装入数组
    lngGistCol = lngGistCol - rngData.Column + 1
    '计算依据列在数组中的位置
    lngColCount = UBound(aData, 2)
    '数据源的列数
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ReDim aRef(1 To UBound(aData))
    For i = 1 To UBound(aData) '处理依据列的异常值,空白/错误值/整行空白等
        If IsError(aData(i, lngGistCol)) Then
            aRef(i) = "错误值"
        ElseIf aData(i, lngGistCol) = "" Then
            strTemp = "" '判断是否整行数据为空
            For j = 1 To lngColCount
                strTemp = strTemp & aData(i, j)
            Next
            If strTemp = "" Then '如果整行为空
                aRef(i) = "整行空白"
            Else
                aRef(i) = "空白单元格"
            End If
        Else
            strKey = aData(i, lngGistCol)
            aRef(i) = strKey
        End If
    Next
    For i = lngTitleCount + 1 To UBound(aData)
        strKey = aRef(i)
        If strKey <> "整行空白" Then
            If Not d.exists(strKey) Then
            '字典中不存在关键字时则遍历建表
                d(strKey) = ""
                ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组
                k = 0
                For x = lngTitleCount + 1 To UBound(aData) '遍历数据源
                    strTemp = aRef(x)
                    If strTemp = strKey Then '如果记录符合条件,则装入结果数组
                        k = k + 1
                        For j = 1 To lngColCount
                            aResult(k, j) = aData(x, j)
                        Next
                    End If
                Next
                For Each sht In ActiveWorkbook.Worksheets '删除旧表
                    If sht.Name = strKey Then sht.Delete
                Next
                With Worksheets.Add(, Sheets(Sheets.Count))
                '新建一个工作表
                    .Name = strKey
                    .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
                    '设置单元格为文本格式
                    If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData
                    '标题行
                    .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
                    '写入数据
                    If strYesOrNo = vbYes Then '如果用户选择保留总表格式
                        rngFormat.Copy
                        .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                         '复制粘贴总表的格式
                        .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
                        '删除多余的格式单元格
                    End If
                    .Range("a1").Select
                End With
            End If
        End If
    Next
    rngData.Parent.Activate '回到总表
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    MsgBox "数据拆分完成!"
End Sub

 

 


回复内容
ZTOA10 2022-06-14 15:54
#1

问题2:使用的时候有时候会不删除新建的VBA模块,而停留在VBA窗口下打开对应的模块

解答:这个通用版模式全程都是使用快捷键运行的。有时候会因为外部干扰造成失败,很正常。

如果你使用offie软件,建议使用office专用的模式,删除失败的概率会降低很多,前提是你存入的代码也要事先测试成功噢。

ZTOA10 最后更新于 2022-06-14 15:54
ZTOA10 2022-06-14 15:29
#2

问题1:动作会默认填零跳过而不让用户输入,从而导致程序运行结果与预计结果不一致

解答:这个之前有朋友反馈过,我自己也测试过,通用版模式的比较适合自动流程化的代码,不支弹窗需要手动输入参数的代码,也就是说如果你使用WPS,一定需要手动输入参数的话建议用官方原来的。因为每个人的需求不同,代码不同,输入参数个也不同。这个只是适合大部分通用需求,需要实现自己想要的目的可以尝试自己修改一下噢。

ZTOA10 最后更新于 2022-06-14 16:00
ZTOA10 回复 ZTOA10 2022-06-14 15:44 :

我看你安装的是office2019的,你可以右键切换到office专用版本的模式试试,这个版本对office办公软件的比较友好,我运行你给的代码实际上是有弹窗提示的


ZTOA10 最后更新于 2022-06-14 15:59
回复主贴