公式转化为VBA

quqiyuan · 发表于 2024-9-22 19:54

改了下，看看是否合适，仅供参考。。。
F2那里清空了，公式肯定也清除掉了，所以我说用数据验证，数据验证它不会清理

quqiyuan · 发表于 2024-9-22 19:55

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Application.ScreenUpdating = False '关闭屏幕刷新
ss = [p1].Value
With Target
      s = Target.Value
      If .Column = 3 And s <> Empty Then
         Application.EnableEvents = False
         If .Offset(0, 1).Value = Empty Then .Offset(0, 1) = Date
         s = .Offset(0, 1).Value
         x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
            DateSerial(Year(s), Month(s) + 1, 5), s + 14)
         If ss <> Empty Then
            If x > ss Then .Offset(0, 2) = ss Else .Offset(0, 2) = x
         Else
            .Offset(0, 2) = x
         End If
         Application.EnableEvents = True
      ElseIf .Column = 3 Then
         Application.EnableEvents = False
         .Offset(0, 1).Resize(, 2).ClearContents
         Application.EnableEvents = True
      End If
End With
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson · 发表于 2024-9-22 22:22

quqiyuan 发表于 2024-9-22 19:55
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

先送上小红花，测试后发现结账日期（D列）无法自动更新，有以下几种情况：
1.生成配票日期后，手动修改配票日期
2.录入或清空盘点日期，已生成的结账日期并超过盘点日
以上情况都无法自动更新，好像必须再次点击C列单元格并回车后才能激活，麻烦您再帮忙看看，谢谢！

quqiyuan · 发表于 2024-9-22 22:54

本帖最后由 quqiyuan 于 2024-9-23 09:05 编辑

divineson 发表于 2024-9-22 22:22
先送上小红花，测试后发现结账日期（D列）无法自动更新，有以下几种情况：
1.生成配票日期后，手动修改 ...

改好了，仅供参考。。。

quqiyuan · 发表于 2024-9-23 09:06

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False '关闭屏幕刷新
ss = [p1].Value
Application.EnableEvents = False
If Target.Count = 1 Then
      With Target
         s = Target.Value
         If .Column = 3 And s <> Empty Then
            If .Offset(0, 1).Value = Empty Then .Offset(0, 1) = Date
            s = .Offset(0, 1).Value
            x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                  DateSerial(Year(s), Month(s) + 1, 5), s + 14)
            If ss <> Empty Then
                  If x > ss Then .Offset(0, 2) = ss Else .Offset(0, 2) = x
            Else
                  .Offset(0, 2) = x
            End If
         ElseIf .Column = 3 Then
            .Offset(0, 1).Resize(, 2).ClearContents
         End If
         If .Column = 4 And s <> Empty Then
            x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                  DateSerial(Year(s), Month(s) + 1, 5), s + 14)
            If ss <> Empty Then
                  If x > ss Then .Offset(0, 1) = ss Else .Offset(0, 1) = x
            Else
                  .Offset(0, 1) = x
            End If
         End If
         If Target.Address = "$P$1" Then
            If ss <> Empty Then
                  r = Me.Cells(Me.Rows.Count, 5).End(3).Row
                  For i = 2 To r
                     If Me.Cells(i, 5).Value > ss Then Me.Cells(i, 5).Value = ss
                  Next
            Else
                  For i = 2 To r
                     s = Me.Cells(i, 4).Value
                     If s <> Empty Then
                        x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                              DateSerial(Year(s), Month(s) + 1, 5), s + 14)
                        Me.Cells(i, 5).Value = x
                     End If
                  Next
            End If
         End If
      End With
Else
      If Target.MergeCells Then
         If Target.Cells(1).Address = "$P$1" Then
            r = Me.Cells(Me.Rows.Count, 5).End(3).Row
            If ss <> Empty Then
                  For i = 2 To r
                     If Me.Cells(i, 5).Value > ss Then Me.Cells(i, 5).Value = ss
                  Next
            Else
                  For i = 2 To r
                     s = Me.Cells(i, 4).Value
                     If s <> Empty Then
                        x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                              DateSerial(Year(s), Month(s) + 1, 5), s + 14)
                        Me.Cells(i, 5).Value = x
                     End If
                  Next
            End If
         End If
      End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson · 发表于 2024-9-23 11:29

quqiyuan 发表于 2024-9-23 09:06
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

经测试，已能完美运行，感谢老师的多次帮忙，已送上小红花！

divineson · 发表于 2024-9-23 16:04

quqiyuan 发表于 2024-9-23 09:06
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

有个小暇疵向老师反馈一下，当多个单元格被选中进行删除时（两个或以上，含C列），D、E列日期无法实现自动清空，如工作表被保护了，会影响使用！

quqiyuan · 发表于 2024-9-23 17:00

divineson 发表于 2024-9-23 16:04
有个小暇疵向老师反馈一下，当多个单元格被选中进行删除时（两个或以上，含C列），D、E列日期无法实现自 ...

刚把代码又理了一下，仅供参考。。。

quqiyuan · 发表于 2024-9-23 17:01

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False '关闭屏幕刷新
ss = [p1].Value
Application.EnableEvents = False
For Each Rng In Target
      With Rng
         s = .Value
         If .Column = 3 And s <> Empty Then
            If .Offset(0, 1).Value = Empty Then .Offset(0, 1) = Date
            s = .Offset(0, 1).Value
            x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                  DateSerial(Year(s), Month(s) + 1, 5), s + 14)
            If ss <> Empty Then
                  If x > ss Then .Offset(0, 2) = ss Else .Offset(0, 2) = x
            Else
                  .Offset(0, 2) = x
            End If
         ElseIf .Column = 3 Then
            .Offset(0, 1).Resize(, 2).ClearContents
         End If
         If .Column = 4 And s <> Empty Then
            x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                  DateSerial(Year(s), Month(s) + 1, 5), s + 14)
            If ss <> Empty Then
                  If x > ss Then .Offset(0, 1) = ss Else .Offset(0, 1) = x
            Else
                  .Offset(0, 1) = x
            End If
         End If
         If .Address = "$P$1" Then
            r = Me.Cells(Me.Rows.Count, 5).End(3).Row
            If ss <> Empty Then
                  For i = 2 To r
                     If Me.Cells(i, 5).Value > ss Then Me.Cells(i, 5).Value = ss
                  Next
            Else
                  For i = 2 To r
                     s = Me.Cells(i, 4).Value
                     If s <> Empty Then
                        x = IIf(s + 14 > DateSerial(Year(s), Month(s) + 1, 5), _
                              DateSerial(Year(s), Month(s) + 1, 5), s + 14)
                        Me.Cells(i, 5).Value = x
                     End If
                  Next
            End If
         End If
      End With
Next
Application.EnableEvents = True
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

divineson · 发表于 2024-9-23 18:06

quqiyuan 发表于 2024-9-23 17:01
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

老师厉害，这么快就解决了，神速，再次送上小红花，万分感谢！

		自动登录	找回密码
密码			免费注册

[求助] 公式转化为VBA

评分

评分

评分