excel - Loop several independent expiration MSG functions -
this codes work perfect , shows message if of customers license has expired (one message customers). copy 12 times check separately in 12 sheets(months). ok. first question if there way check months (sheets) 1 code , show 1 message months, told me each customer expire month. , second in case no sheet have expire message inform me message no 1 expires in no sheet.
sub expire_date_1_15() dim lrow long dim lname string dim lphone string dim lresponse string dim ldiff long dim ldays long lrow = 2 'start @ row 2 ldays = 40 'warning - number of days check expiration sheets("1_15") 'check first 37 rows in column c while lrow < 36 'only check expired certificate if value in column s not blank if isdate(.range("r" & lrow)) ldiff = .range("r" & lrow).value2 - date if (ldiff > 0) , (ldiff <= ldays) '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)) _ msgbox "Τα συμβόλαια των παρακάτω πελατών για τον μήνα Μάρτιο 2015 : " & chr(10) & vbcrlf & lresponse, vbcritical, "ΕΝΗΜΕΡΩΣΗ ΛΗΞΗΣ ΣΥΜΒΟΛΑΙΩΝ" end call expire_date_2_15 end sub sub expire_date_2_15() dim lrow long dim lname string dim lphone string dim lresponse string dim ldiff long dim ldays long lrow = 2 'start @ row 2 ldays = 40 'warning - number of days check expiration sheets("2_15") 'check first 37 rows in column c while lrow < 36 'only check expired certificate if value in column s not blank if isdate(.range("r" & lrow)) ldiff = .range("r" & lrow).value2 - date if (ldiff > 0) , (ldiff <= ldays) '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)) _ msgbox "Τα συμβόλαια των παρακάτω πελατών για τον μήνα Απρίλιο 2015 : " & chr(10) & vbcrlf & lresponse, vbcritical, "ΕΝΗΜΕΡΩΣΗ ΛΗΞΗΣ ΣΥΜΒΟΛΑΙΩΝ" end expire_date_Μάϊος_15 end sub
as sub same each month except name of sheet, can re-use supplying call parameter. @ same time, relocate msgbox
code month loop subroutine:
sub check_all_sheets() dim month integer dim n_expired integer n_expired = 0 month = 1 12 ret = expire_date(month) if len(ret) > 0 n_expired = n_expired + 1 msgbox ("expired: " & ret) end if next month msgbox ("total licences expired: " & n_expired) end sub function expire_date(month integer) string dim lrow long dim lname string dim lphone string dim lresponse string dim ldiff long dim ldays long dim sh_name string lrow = 2 'start @ row 2 ldays = 40 'warning - number of days check expiration lresponse = "" ' sh_name = cstr(month) & "_15" sh_name = monthname(month) & "_15" ' e.g. "may_15" sheets(sh_name) 'check first 37 rows in column c while lrow < 36 'only check expired certificate if value in column s not blank if isdate(.range("r" & lrow)) ldiff = .range("r" & lrow).value2 - date if (ldiff > 0) , (ldiff <= ldays) '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 expire_date = lresponse end function
btw, think code not checking first 37 rows rows 2..35.
Comments
Post a Comment