公式转化为VBA

divineson

因公式经常被误删除，求大神指点将公式转化为VBA，需求如下：
每班关键信息录入表
1.配票日期修改后，结账日期无法自动更新
2.”IFERROR(MIN(IF([@配票日期]<>0,IF(AND([@配票日期]+14>$P$1,$P$1<>0),INDEX($P$1,1,1),[@配票日期]+14),""),EOMONTH([@配票日期],0)+5),"")“将此公式转化为VBA，功能：1.结账日期=配票日期+14，跨月时则不超过下月的5号；2.当盘点日（P1）非空时，结账日期大于盘点日的则自动变更为盘点日。

车票出入库表
因数据录入后需清空F2，其公式：IFERROR(INDIRECT("车票结存!I"&$V$1),"")也会被清空，是改变清空的语句还是将公式变为VBA，请大神指点一下，谢谢！

沈默00

工作表保护，，，隐藏公式，，

divineson

沈默00 发表于 2024-9-22 08:25
工作表保护，，，隐藏公式，，

密码应该都取消了，如果还有的话都是:1，附件也重新上传了，主要也就两条公式需转化，都写在一楼了。

ynzsvt

divineson 发表于 2024-9-22 08:38
密码应该都取消了，如果还有的话都是:1，附件也重新上传了，主要也就两条公式需转化，都写在一楼了。

你楼上是提供给你的方法

divineson

ynzsvt 发表于 2024-9-22 08:40
你楼上是提供给你的方法

不好意思，我误会了，之前就是用这个方法的，主要是确实有需要手动修改的时候，很多同事使用中表格解除保护都没有及时重新保护，导致公式被删除，所以才想进行转化！

quqiyuan

参与一下，仅供参考。。。
f2单元格选择人名的，定义了名称，然后数据验证，你清除内容，不影响数据验证，由于不知道你在哪个地方需要清除f2单元格内容，写了一行代码，你搬一下就可

quqiyuan

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False '关闭屏幕刷新
    With Target
        s = Target.Value
        If .Column = 4 And s <> Empty Then
            Application.EnableEvents = False
            .Offset(0, 1) = Format(IIf(s + 14 > DateSerial(Year(s), _
                Month(s) + 1, 5), DateSerial(Year(s), Month(s) + 1, 5), s + 14), "m-d")
            Application.EnableEvents = True
        Else
            Application.EnableEvents = False
            .Offset(0, 1).ClearContents
            Application.EnableEvents = True
        End If
    End With
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

Sub 删除f2()
    Sheet8.[f2] = Empty
End Sub

divineson

quqiyuan 发表于 2024-9-22 09:37
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

首先感谢大神再次出手相助
1.清空”车票出入库“F2单元格是用于您帮我设计的出入库程序中，我在出库、入库的模块中都最后增加了一条”ws.Range("f2").ClearContents“语句，但将单元格内的公式也清除了，不知能知将该条公式也转化为VBA。
公式：IFERROR(INDIRECT("车票结存!I"&$V$1),"")，功能就是点击切片器中的姓名时能在F2中显示。
Sub 入库1()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:b" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            For j = 1 To UBound(ar, 2)
                br(n, j + 1) = ar(i, j)
            Next j
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = .Cells(Rows.Count, "h").End(xlUp).Row + 1
        .Cells(r, "h").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 1 To n
                y = Application.Match(br(i, 2), dr, 0)
                cr(x, y) = Empty
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("B2:B" & rs).ClearContents
    ws.Range("f2").ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

Sub 出库1()
    Application.ScreenUpdating = False '关闭屏幕刷新
    Dim ar As Variant
    Dim br()
    Dim rowCount As Long
    Dim ws As Worksheet
    Set ws = Worksheets("车票出入库")
    rs = ws.Cells(Rows.Count, 3).End(xlUp).Row
    If rs < 2 Then MsgBox "请先录入数据!": End
    ar = ws.Range("a1:c" & rs)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" Then
            n = n + 1
            br(n, 1) = Format(Date, "m-d")
            br(n, 2) = ar(i, 1)
            br(n, 3) = ar(i, 3)
        End If
    Next i
    If n = "" Then MsgBox "数据源为空,请先录入数据!": End
    With ws
        r = ws.Cells(Rows.Count, "k").End(xlUp).Row + 1
        .Cells(r, "k").Resize(n, UBound(br, 2)) = br
    End With
    If Len(ws.[f2].Value) > 0 Then
        With Sheets("车票结存")
            cr = .[i1].CurrentRegion
            dr = Application.Index(cr, 1)
            x = Application.Match(ws.[f2].Value, .Columns("i"), 0)
            For i = 1 To n
                y = Application.Match(br(i, 2), dr, 0)
                cr(x, y) = cr(x, y) + br(i, 3)
            Next
            .[i1].CurrentRegion = cr
        End With
    End If
    ws.Range("c2:c" & rs).ClearContents
    ws.Range("f2").ClearContents
    Application.ScreenUpdating = True '开启屏幕刷新
End Sub

2.1）关于”每班关键信息录入表“日期功能设置能否将原有的当C列非空时，配票日期（D列）能自动记录当前日期且除非手动更改D列日期，否则不再变动；2）当清空C列数据时，D列、E列同步清空；3）盘点日录入日期时（即P1-P6的合并单元格内），如结账日期大于盘点日期的均按盘点日期显示，清空盘点日期则按原规则显示。麻烦大神再帮忙看看能否实现这此功能，万分感谢！

quqiyuan

divineson 发表于 2024-9-22 09:28
不好意思，我误会了，之前就是用这个方法的，主要是确实有需要手动修改的时候，很多同事使用中表格解除保 ...

divineson

quqiyuan 发表于 2024-9-22 12:36

感谢大神多次的帮助，日期公式的部分功能仍未能实现，可否帮忙再完善一下：
1. C列非空时，配票日期（D列）自动生成当前日期，且C列在不清空的情况下更改数据不会造成配票目期的变化，除非手动更改配票日期
2. 清空C列数据时，D列、E列一并清空
3. P1合并单元格非空时，结账日期大于P1则按P1日期显示，清空P1格后则按原规则
4. F2单元格的清空是用于您帮忙设计的出入库功能中，因与切片器连接，在F2单元格内设有公式配合调用数据，我已在您的程序内加入了F2清空的语句，但却连公式也一并清除了，看能否也将该公式也转为VBA
请大神再帮忙改一下，万分感谢！