求写个自动计算的VBA代码~

jyljb888 2018-05-04 11:11:43

效果详见图片，自动计算和引用单元格

...全文

3434 15 打赏收藏转发到动态举报

写回复

用AI写文章

15 条回复

切换为时间正序

请发表友善的回复…

发表回复

weixin_44124917 2019-02-08

打赏
举报

milaoshu1020 2018-10-17

打赏
举报

4.开根号用sqr函数,如: "sqr(3)",结果为1.732...

milaoshu1020 2018-10-17

打赏
举报

请叫我雷锋!
1.打开VBA,添加如下引用:
Microsoft Script Control 1.0
Microsoft VBScript Regular Expressions 5.5
2.在模块1中添加如下代码.

Public Function Calc(ByVal varFormula As Variant) As Variant

    On Error GoTo hErr

    Dim strFormula As String

    Dim reg As New RegExp

    reg.Global = True

    reg.Pattern = "\{[^}]*\}"

    strFormula = reg.Replace(varFormula, "")

    

    Dim ctlScript As New ScriptControl

    ctlScript.Language = "VBScript"

    ctlScript.AllowUI = True

    ctlScript.Reset

    

    Dim i As Integer

    For i = 2 To 2000

        Dim strVarName As String

        strVarName = Trim(varFormula.Parent.Range("K" & i))

        

        If strVarName <> "" Then

            ctlScript.AddCode (strVarName & "=" & varFormula.Parent.Range("J" & i))

        End If

    Next

    

    Calc = ctlScript.Eval(strFormula)

    Exit Function

hErr:

    Debug.Print Err.Number & ": " & Err.Description

End Function

3.在Excel表格的I2等单元格中输入=Calc(H2)

舉杯邀明月 2018-10-08

打赏
举报

楼主都失踪了，你们还在回复。

worldy 2018-10-08

打赏
举报

引用楼主 jyljb888 的回复:

效果详见图片，自动计算和引用单元格

LZ可以使用VBSCript，但是引用单元格你必须自己进行预处理

无·法 2018-10-08

打赏
举报

K2 K3那儿可以编写个函数计算，再下面的引用K2和K3的可以完全通过excel公式来处理了。楼主的需求可实现，论坛是针对具体问题讨论解决的地方，目的是学习交流，不是免费定制程序的地方，大家可以提供个大概的思路，具体需要你自己来实现的。

你这个明显是偏应用方面，如果让人完全给你编写代码那是要付出劳务费的。

另外，你提供的代码并不能满足你的要求，从你的描述来看对编程似乎不懂，稍有点基础的人几十秒一扫你的代码就知道根本和你的需求不搭边的，所以楼主明显不是抱着“学习交流”的目的，只是想要一个可直接使用的程序，对具体如何实现并不感兴趣。建议楼主发项目zbj.com

weixin_43321923 2018-10-05

打赏
举报

其他好像不难解决，开方也有公式，但你在H栏里怎么表达开方，不然程序不好判断

q8254733 2018-05-29

打赏
举报

第一条用，正则配合EVALUATE函数第二条FOREACH J列每个单元格，自定义名称为K列对应的就好第三条，开方你准备怎么写，使用上标吗？

赵4老师 2018-05-07

打赏
举报

VBA不是支持调用VBScript吗？

脆皮大雪糕 2018-05-06

打赏
举报

这不就是excel的公式就能搞定的，搞那么复杂干啥

jyljb888 2018-05-04

打赏
举报

哪个功能比较难啊？？？？

jyljb888 2018-05-04

打赏
举报

引用 1 楼舉杯邀明月的回复:

这个有点类似于”脚本解释“了，工作量比较大的。我觉得没有谁愿意做这种”免费劳工“。　　当然，手里有现成代码的人，也许可以稍加修改，提供给你。没看出你的 I列和J列有什么区别。不是一样的数据么！　弄两列岂不是多此一举？

j列是等于是用i的数据乘以前面相同层次相同构件

舉杯邀明月 2018-05-04

打赏
举报

这个有点类似于”脚本解释“了，工作量比较大的。我觉得没有谁愿意做这种”免费劳工“。　

　当然，手里有现成代码的人，也许可以稍加修改，提供给你。没看出你的 I列和J列有什么区别。不是一样的数据么！　弄两列岂不是多此一举？

舉杯邀明月 2018-05-04

打赏
举报

这个“代码”能满足你的需求？我可没看出上面这段代码跟你的“需求”有什么关联。

jyljb888 2018-05-04

打赏
举报

引用 1 楼 Chen8013 的回复:

这个有点类似于”脚本解释“了，工作量比较大的。我觉得没有谁愿意做这种”免费劳工“。　　当然，手里有现成代码的人，也许可以稍加修改，提供给你。没看出你的 I列和J列有什么区别。不是一样的数据么！　弄两列岂不是多此一举？

老哥，下面的这个代码能满足我的要求，只是需要修改一下，你会修改吗？

Option Explicit

Private Const 标题行数 = 4
Private Const 目标列序号 = 4
Private Const Prefix$ = ".*" '在textbox1中预先添加的前缀符（正则表达式中用“.*”可匹配任意字符）
Private RequiredSmartCplt As Boolean '需要刷新匹配结果的标记
Private HelperReady As Boolean '辅助输入工具就绪标记
'Dim txt$ '检测文本框变化
' 以拼音首字母提示自动完成

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, c&, TVal, SourceData(), vTarget, sTmp$, tf As Boolean, ls, i&, cexp
    r = Target.Row:    If r <= 标题行数 Then Exit Sub
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    tf = (Cells(r, 2) & Cells(r, 4) & Cells(r, 5) <> "")
    If Err.Number Then Err.Clear: tf = True
    If tf Then ls = 1: Cells(r, 1) = r Else Cells(r, 1) = Empty
    Cells(r, 1).Resize(1, 8).Borders.LineStyle = ls
    With Cells(r, 6).Validation
        .Delete
        If tf Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=单位"
            .IgnoreBlank = True
            .InCellDropdown = True
        End If
    End With
    If InStr(Target.Address, ":") > 0 Then Application.EnableEvents = True: Exit Sub
    TVal = Replace(Target.Value, Chr(127), "")
    If Len(TVal) Then TVal = Chr(127) & TVal
    c = Target.Column
    Select Case c
    Case 3
        Target.Interior.Pattern = xlNone
        检测重复代号 Target
    Case 4
        If IsEmpty(TVal) Then
            Target.Offset(, 2) = Empty
        Else
            For i = 1 To UBound(DataSource)
                If InStr(TVal, DataSource(i, 1)) Then
                    Target.Offset(, 2) = DataSource(i, 3) '单位
                    Exit For
                End If
            Next
        End If
    Case 5
        If bDgotoNextA Then _
            Rows(r + 1).SpecialCells(xlCellTypeVisible).Cells(1).Select
    Case 6
        If bDgotoNextA Then Cells(r + 1, c).Select
    Case 8
        Target = TVal
        With Cells(r, 7)
            If Len(TVal) Then
                cexp = ExpClean(Target)
                .Formula = cexp(1)
                If Err.Number Then .Formula = "##括号不配对或参数不符": Err.Clear ' Else
                .Value = .Value
                .NumberFormat = "0.00;[Red]@"
                If Left(.Text, 3) = "###" Then .NumberFormat = "0.00E+00"
            Else
                .Formula = ""
                .EntireRow.AutoFit
            End If
        End With
        检测重复代号 Target
        Cells(r + 1, c).Select
    Case Else
    End Select
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If bUserInput Or InStr(Target.Address, ":") > 0 Or FitIsNothing(Target) Then
        ZoomOutToZero
        If Target.Column > 9 Then ActiveCell.Offset(1).EntireRow.SpecialCells(xlCellTypeVisible).Cells(1).Select
        Exit Sub
    End If
    Call FitTarget
    RequiredSmartCplt = True: If Target.Value = "" Then TextBox1 = Prefix Else TextBox1 = Target.Value '其中，Prefix=".*"
End Sub

Private Sub SmartCompletion() '自动完成
    Dim s$, i&
    
    If TextBox1 = Prefix Then RequiredSmartCplt = True
    If Not RequiredSmartCplt Then Exit Sub
    With ListBox1
        .Clear
        If Not Initialized Then Initializ
        s = Replace(TextBox1, "|", "\|")
        s = Replace(s, " ", "")
        If Len(s) < lLowBound Then Exit Sub
        RegE.Pattern = s 'HzToPy(s, , , True, True) '拼音
        On Error Resume Next
        For i = 1 To UBound(DataSource) '
            If RegE.test(DataSource(i, 2)) Then .AddItem DataSource(i, 1)                '正则式匹配
        Next
        If .ListCount Then .ListIndex = 0
    End With
End Sub

Private Sub 输入(ByVal Shift As Integer)
    '区分情况，从列表框值和文本框值两者选一，输入活动单元格
    Dim Founded As Boolean, strtmp$
    Founded = ListBox1.ListIndex > -1 '判断listbox1中是否有匹配项
    strtmp = Replace(Left(TextBox1.Value, Len(Prefix)), Prefix, "") & Mid(TextBox1.Value, Len(Prefix) + 1) '取textbox1手工输入的有效字符（排除其开始位置处由代码添加的".*")
    If Founded Then
        If Shift = 2 Then
            ActiveCell = ListBox1.Value '强制以列表框的值输入
        Else
            ActiveCell = IIf(strtmp = "", "", ListBox1.Value) '只有当列表框的值是正常匹配到的才输入，否则输入空
        End If
    Else
        ActiveCell = strtmp '输入文本框的有效字符
    End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    HelperReady = True
    Select Case KeyCode
        Case vbKeyEscape 'Esc键
            ActiveCell.Select
            Call ZoomOutToZero '临时关闭文本框和列表框
            RequiredSmartCplt = True
        Case Else
    End Select
End Sub

Private Sub TextBox1_Change() '根据已输入内容查找关键字列表
    Call SmartCompletion
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'   鼠标双击列表框则直接输入其值并隐藏辅助工具，方便鼠标选择其它目标单元格
    ActiveCell.Value = ListBox1.Value
    Call ZoomOutToZero
End Sub

'判断按键,以完成回车输入,左右上下方向键及Tab键选择功能,以及Ctrl+ E 切换输入状态
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim i&, c&
With ListBox1
    Select Case KeyCode
    Case vbKeyReturn '回车键
        If HelperReady Then
            Call 输入(Shift)  '调用输入模块
            With ActiveCell
                Select Case Application.MoveAfterReturnDirection
                    Case xlDown: Range(.Offset(1, 0), Cells(Rows.Count, .Column)).SpecialCells(xlCellTypeVisible).Item(1).Select
                    Case xlUp: .Offset(-1).Select
                    Case xlToLeft: .Previous.Select
                    Case Else: .Next.Select
                End Select
            End With
        End If
        RequiredSmartCplt = False
    Case 17 '仅按Ctrl一键
        RequiredSmartCplt = False
    Case vbKeyE 'Ctrl+ E 切换输入状态
        If Shift = 2 Then Call 输入状态切换
    Case vbKeyDown '按向下箭头键
        RequiredSmartCplt = False
        If HelperReady Then
            If .ListCount < 1 Or .ListIndex = .ListCount - 1 Then
                ActiveCell.Offset(1).Activate '如果列表框没有项或已经是最后项，则激活下一单元格
            ElseIf Shift = 2 Then
                .ListIndex = .ListCount - 1 '否则如果同时按了Ctrl键，则激活列表框最后项
                Exit Sub
            Else
                .ListIndex = .ListIndex + 1 '否则激活列表框的下一项
            End If
        End If
    Case vbKeyUp '按向上箭头键
        RequiredSmartCplt = False
        If HelperReady Then
            If .ListCount < 1 Or .ListIndex = 0 Then
                ActiveCell.Offset(-1).Activate '如果列表框没有项或已经是第一项，则激活上一单元格
            ElseIf Shift = 2 Then
                .ListIndex = 0 '否则如果同时按了Ctrl键，则激活列表框第一项
            Else
                .ListIndex = .ListIndex - 1 '否则激活列表框的上一项
            End If
        End If
    Case vbKeyTab 'Tab键
        RequiredSmartCplt = False
        If HelperReady Then If Shift = 2 Then ActiveCell.Previous.Select Else ActiveCell.Next.Select
    Case vbKeyLeft '左方向键
        RequiredSmartCplt = False
        If HelperReady Then ActiveCell.Previous.Select
    Case vbKeyRight '右方向键
        RequiredSmartCplt = False
        If HelperReady Then ActiveCell.Next.Select
    Case vbKeyDelete '按delete键，则清空列表框
        RequiredSmartCplt = True
        TextBox1.Text = ""
        ActiveCell.ClearContents
    Case Else
        RequiredSmartCplt = True
        Call SmartCompletion
    End Select
End With
End Sub
Private Sub FitTarget()
    Dim t#, l#, w#, h#, s#
    With ActiveCell
        t = .Top
        l = .Left
        w = .Offset(, 4).Left - .Left ' 取相邻共4列的总宽度
        h = .Height
        s = .Font.Size
    End With
    With Me.ListBox1
        .Top = t + h + 1
        .Left = l
        .Width = w + 15 '列表框的滚动条宽度约15
        .Font.Size = s
        .Height = h * 6
        .Visible = True
    End With
    With Me.TextBox1
        .Top = t
        .Left = l
        .Width = w
        .Height = h + 1
        .Font.Size = s - 1
        .Visible = True
        .Activate
        .IMEMode = fmIMEModeDisable '列表框激活时自动切换回英文输入，方便输入拼音首字母。
    End With
End Sub
Private Sub ZoomOutToZero()
    Application.ScreenUpdating = False
    With Me.TextBox1
        .Width = 0
        .Height = 0
        .Visible = False
        RequiredSmartCplt = False
        .Text = ""
        RequiredSmartCplt = True
    End With
    With Me.ListBox1
        .Width = 0
        .Height = 0
        .Visible = False
        .Clear
    End With
    HelperReady = False '
End Sub
Private Function FitIsNothing(ByVal Target As Range) As Boolean
    FitIsNothing = Target.Column <> 目标列序号 Or Target.Row <= 标题行数
End Function

Private Sub 检测重复代号(ByVal Target As Range)
    Dim r&, Cel As Range, sTmp As String, i&, sh As Worksheet
    r = Target.Row
    Set Cel = Cells(r, 3)
    sTmp = UCase(Cel)
    If Len(sTmp) Then
        For i = 4 To r - 1
            If UCase(Cells(i, 3)) = sTmp Then Exit For
        Next
        If i = r Then
            添加代号 Cel
        Else
            MsgBox "代号 “" & sTmp & "” 重复！"
            Range("C" & r).Interior.Color = vbYellow
        End If
    Else
        整理代号
    End If
End Sub

Private Sub 添加代号(ByVal Target As Range)
    Dim Cel As Range
    Set Cel = Target.Parent.Cells(Target.Cells(1).Row, 3)
    Cel.Interior.Pattern = xlNone
    If Len(Cel) Then
        Cel = UCase(Cel)
        Application.Names.Add Cel.Value, Cel.Offset(, 4)
    End If
End Sub