Question

如果我的客户许可证已过期（所有客户都有一条消息），此代码可以完美运行并显示消息。我复制了12次，分别以12张（月）为单位进行检查。一切都好。所以我的第一个问题是，是否有任何方法可以检查所有月份（表格）和一个代码并显示所有月份的一条消息，但是告诉我每个客户到期月份。第二个是我希望在这种情况下没有工作表有过期消息通知我没有任何人在没有工作表到期的消息。

Sub expire_date_1_15()

    Dim LRow As Long
    Dim LName As String
    Dim LPhone As String
    Dim LResponse As String
    Dim LDiff As Long
    Dim LDays As Long

    LRow = 2   'start at row 2
    LDays = 40 'Warning - Number of days to check for expiration

    With Sheets("1_15")
        'Check the first 37 rows in column C
        While LRow < 36

            'Only check for expired certificate if value in column S is not blank
            If IsDate(.Range("R" & LRow)) Then
                LDiff = .Range("R" & LRow).Value2 - Date
                If (LDiff > 0) And (LDiff <= LDays) Then
                    'Get  names
                    LName = .Range("B" & LRow).value
                    LNphone = .Range("c" & LRow).value
                    LResponse = LResponse & LName & " με αριθμό τηλ. " & LNphone & " λήγει σε " & LDiff & " μέρες." & Chr(10)
                End If
            End If

            LRow = LRow + 1
        Wend
        If CBool(Len(LResponse)) Then _
            MsgBox "Τα συμβόλαια των παρακάτω πελατών για τον μήνα Μάρτιο 2015 : " & Chr(10) & vbCrLf & LResponse, vbCritical, "ΕΝΗΜΕΡΩΣΗ ΛΗΞΗΣ ΣΥΜΒΟΛΑΙΩΝ"

    End With

    Call expire_date_2_15

End Sub

Sub expire_date_2_15()

    Dim LRow As Long
    Dim LName As String
    Dim LPhone As String
    Dim LResponse As String
    Dim LDiff As Long
    Dim LDays As Long

    LRow = 2   'start at row 2
    LDays = 40 'Warning - Number of days to check for expiration

    With Sheets("2_15")
        'Check the first 37 rows in column C
        While LRow < 36

            'Only check for expired certificate if value in column S is not blank
            If IsDate(.Range("R" & LRow)) Then
                LDiff = .Range("R" & LRow).Value2 - Date
                If (LDiff > 0) And (LDiff <= LDays) Then
                    'Get  names
                    LName = .Range("B" & LRow).value
                    LNphone = .Range("c" & LRow).value
                    LResponse = LResponse & LName & " με αριθμό τηλ. " & LNphone & " λήγει σε " & LDiff & " μέρες." & Chr(10)
                End If
            End If

            LRow = LRow + 1
        Wend
        If CBool(Len(LResponse)) Then _
            MsgBox "Τα συμβόλαια των παρακάτω πελατών για τον μήνα Απρίλιο 2015 : " & Chr(10) & vbCrLf & LResponse, vbCritical, "ΕΝΗΜΕΡΩΣΗ ΛΗΞΗΣ ΣΥΜΒΟΛΑΙΩΝ"

    End With

    expire_date_Μάϊος_15

End Sub

Answer 1

由于除了工作表的名称之外，每个月的Sub始终相同，因此您可以通过提供调用参数来重复使用它。同时，将MsgBox代码重新定位到月循环子例程：

Sub check_all_sheets()
    Dim month As Integer
    Dim n_expired As Integer

    n_expired = 0
    For month = 1 To 12
        ret = expire_date(month)
        If Len(ret) > 0 Then
            n_expired = n_expired + 1
            MsgBox ("expired: " & ret)
        End If
    Next month
    MsgBox ("Total licences expired: " & n_expired)
End Sub

Function expire_date(month As Integer) As String
    Dim LRow As Long
    Dim LName As String
    Dim LPhone As String
    Dim LResponse As String
    Dim LDiff As Long
    Dim LDays As Long
    Dim sh_name As String

    LRow = 2   'start at row 2
    LDays = 40 'Warning - Number of days to check for expiration
    LResponse = ""

    ' sh_name = CStr(month) & "_15"
    sh_name = MonthName(month) & "_15"  ' e.g. "May_15"
    With Sheets(sh_name)
        'Check the first 37 rows in column C
        While LRow < 36
            'Only check for expired certificate if value in column S is not blank
            If IsDate(.Range("R" & LRow)) Then
                LDiff = .Range("R" & LRow).Value2 - Date
                If (LDiff > 0) And (LDiff <= LDays) Then
                    'Get  names
                    LName = .Range("B" & LRow).Value
                    LNphone = .Range("c" & LRow).Value
                    LResponse = LResponse & LName & " με αριθμό τηλ. " & LNphone & " λήγει σε " & LDiff & " μέρες." & Chr(10)
                End If
            End If
            LRow = LRow + 1
        Wend
    End With
    expire_date = LResponse
End Function

顺便说一下，我认为代码不会检查前37行，而只检查行2..35。

循环几个独立的到期MSG功能

1 个答案: