Consulting

Results 1 to 4 of 4

Thread: Solved: Complele Daily Entries before Closing Worksheet

  1. #1
    VBAX Contributor
    Joined
    Dec 2006
    Posts
    193
    Location

    Solved: Complele Daily Entries before Closing Worksheet

    last week you helped me to convert a code to opperate on a daily basis dependng on the day of the week.I need to force people to complete specific entries prior to closing Could you help me insert a code to make the vba code below opperate on a daily basis.The workbook has only one sheet. I would like Rng1-Rng8 to be linked to a day of the week Rng1 being Tuesday thru to Rng8 Monday.If today was Wednesday Rng1-Rng3 would be active, the other Ranges would not be effected as the data is not required untill due date I would be glad of any Help

    Thks

    [VBA]
    Private Sub Workbook_BeforeClose(Cancel As Boolean)




    Dim Start As Boolean
    Dim Rng1 As Range, Rng3 As Range, Rng4 As Range, Rng5 As Range, Rng6 As Range, Rng7 As Range, Rng8 As Range

    Dim Prompt As String, RngStr As String
    Dim Cell As Range
    'set your ranges here
    'Rng1 is on sheet "Group Profile" and cells B5 through B14
    'Cell F1, A range of F5 through F7 etc. you can change these to
    'suit your needs.
    Set Rng1 = Sheets("DAILY STOCK").Range("d5:d200")
    Set Rng3 = Sheets("DAILY STOCK").Range("f5:f200")
    Set Rng4 = Sheets("DAILY STOCK").Range("h5:h200")
    Set Rng5 = Sheets("DAILY STOCK").Range("j5:j200")
    Set Rng6 = Sheets("DAILY STOCK").Range("l5:l200")
    Set Rng7 = Sheets("DAILY STOCK").Range("n5:n200")
    Set Rng8 = Sheets("DAILY STOCK").Range("p5200")
    Set Rng9 = Sheets("DAILY STOCK").Range("v5:v200")

    'message is returned if there are blank cells
    Prompt = "Please check your data ensuring all required " & _
    "cells are complete." & vbCrLf & "you will not be able " & _
    "to close or save the workbook until the form has been filled " & _
    "out completely. " & vbCrLf & vbCrLf & _
    "The following cells are incomplete and have been highlighted yellow:" _
    & vbCrLf & vbCrLf
    Start = True
    'highlights the blank cells
    For Each Cell In Rng1
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng3
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng4
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng5
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng6
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng7
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng8
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Start = True
    If RngStr <> "" Then RngStr = RngStr & vbCrLf & vbCrLf
    For Each Cell In Rng9
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & Cell.Parent.Name & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next




    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    If RngStr <> "" Then
    MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
    Cancel = True
    Else
    'saves the changes before closing
    ThisWorkbook.Save
    Cancel = False
    End If

    Set Rng1 = Nothing
    Set Rng3 = Nothing
    Set Rng4 = Nothing
    Set Rng5 = Nothing
    Set Rng6 = Nothing
    Set Rng7 = Nothing
    Set Rng8 = Nothing


    End Sub
    [/VBA]

  2. #2
    Hi Benson

    This, again, should be done with a loop. However, it's a bit confusing why you don't use Rng2 as a range. Why Rng1, Rng3, Rng4, etc? I assumed it was not important how the ranges were called, so I took the liberty to create new names in my version of the code. It's the array Rng(8).

    I don't know what should be done with Rng9, (in my version Rng(8),) because, if I got it right, it belongs to neither of the days, and you haven't explicitely expressed your will about it. So my code doesn't check it at all. But it would be simple enough to update, once I know the goal.

    Also, I replaced Cell.Parent.Name with UCase(DayName(DayIndex - 1)). The former added the sheet's name before the list of empty cells of each range, which made sense when there were separate sheets for each day. But now the worksheet name is the same for all ranges. The latter, on the other hand, adds the day's name, which is different for each range.

    Please comment.

    [vba]Option Explicit

    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim Start As Boolean
    Dim Rng(8) As Range
    Dim ThisDay As Long, DayIndex As Long, DayName


    Dim Prompt As String, RngStr As String
    Dim Cell As Range

    'set your ranges here
    'Rng1 is on sheet "Group Profile" and cells B5 through B14
    'Cell F1, A range of F5 through F7 etc. you can change these to
    'suit your needs.
    Set Rng(1) = Sheets("DAILY STOCK").Range("d5:d200")
    Set Rng(2) = Sheets("DAILY STOCK").Range("f5:f200")
    Set Rng(3) = Sheets("DAILY STOCK").Range("h5:h200")
    Set Rng(4) = Sheets("DAILY STOCK").Range("j5:j200")
    Set Rng(5) = Sheets("DAILY STOCK").Range("l5:l200")
    Set Rng(6) = Sheets("DAILY STOCK").Range("n5:n200")
    Set Rng(7) = Sheets("DAILY STOCK").Range("p5200")
    Set Rng(8) = Sheets("DAILY STOCK").Range("v5:v200")

    ThisDay = Weekday(Date, vbTuesday)
    DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday")

    'message is returned if there are blank cells
    Prompt = "Please check your data ensuring all required " & _
    "cells are complete." & vbCrLf & "you will not be able " & _
    "to close or save the workbook until the form has been filled " & _
    "out completely. " & vbCrLf & vbCrLf & _
    "The following cells are incomplete and have been highlighted yellow:" _
    & vbCrLf & vbCrLf
    Start = True
    'highlights the blank cells
    For DayIndex = 1 To ThisDay
    For Each Cell In Rng(DayIndex)
    If Cell.Value = vbNullString Then
    Cell.Interior.ColorIndex = 6 '** color yellow
    If Start Then RngStr = RngStr & UCase(DayName(DayIndex - 1)) & vbCrLf
    Start = False
    RngStr = RngStr & Cell.Address(False, False) & ", "
    Else
    Cell.Interior.ColorIndex = 0 '** no color
    End If
    Next
    If RngStr <> "" Then RngStr = Left$(RngStr, Len(RngStr) - 2)
    Next DayIndex

    If RngStr <> "" Then
    MsgBox Prompt & RngStr, vbCritical, "Incomplete Data"
    Cancel = True
    Else
    'saves the changes before closing
    ThisWorkbook.Save
    Cancel = False
    End If
    End Sub[/vba]
    -------------------------------------------------
    The more details you give, the easier it is to understand your question. Don't save the effort, tell us twice rather than not at all. The amount of info you give strongly influences the quality of answer, and also how fast you get it.

  3. #3
    VBAX Contributor
    Joined
    Dec 2006
    Posts
    193
    Location
    Many Thks for the code Jimmy,Range 9 (NOW RNG 8) is a closing stock column and should be completed on the same day as RNG 7 .So in effect the user must be forced to enter data into RNG7 & RNG8 on the MONDAY.

    I am really thankful for all the help I receive from you guys .

  4. #4
    Well, then. Most of the code is the same, only one line new, and one modified.

    [vba] ThisDay = Weekday(Date, vbTuesday) '<-- this line is unchanged
    if ThisDay = 7 Then ThisDay = 8 '<-- this is a new line, forcing the loop to process Rng(8) when it's 7th day of week (i.e. on Monday).
    DayName = Array("Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday", "Monday", "Closing Stock")) '<-- this line is modified. Added name for "8th day" [/vba] I haven't tested it, but it should work.


    Jimmy
    -------------------------------------------------
    The more details you give, the easier it is to understand your question. Don't save the effort, tell us twice rather than not at all. The amount of info you give strongly influences the quality of answer, and also how fast you get it.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •