Modify macro to set background color and lock each cell in workbook containing the date set in named range 'sdate'

The following is a summary of what I need Sub ColorAndProtectCells() to do... (file attached)

1) with each workbook in active folder except this workbook and with each worksheet on each workbook in the active folder:
    1.1)  unprotect worksheet
     1.2) with each active worksheet find cells matching 'sdate' cell D1 on the "Summary" tab
            1.2.1) for each cell found having exact match to 'sdate'
                      1.2.1.1) set background = yellow ("RGB:255,255,0") AND...
                      1.2.1.2) set cell protection Lock cell = True
      1.3) re-protect each worksheet to lock protected cells having same date as 'sdate'
     NOTE: All blank cells with no background color in range I2:last row of last column are preset to unprotect allowing entry while the workbooks are protected. Later, the Sub ColorAndProtect is run to lock the new entries = 'sdate' to prevent changes after which the workbooks are protected and saved.
   2) End Sub
--------------------------------
This is the macro needing revision to color& protect (Lock = True) cells = 'sdate'...
'-------------------------------
Sub ColorAndProtectCells()
' Macro 9/5/15, with each workbook in active folder except this workbook and with each worksheet: unprotect ' 'worksheet; with each worksheet find cells matching 'sdate',  cell D1 on the "Summary" tab and..._
'      set each cell = 'sdate' with background = yellow ("RGB:255,255,0") AND Lock cell = Yes for each cell = 'sdate', then re-protect each worksheet, End Sub
Dim Dwb As Workbook, Swb As Workbook
Dim Sws As Worksheet, ws As Worksheet
Dim slr As Long, lr As Long
Dim rng As Range, cell As Range
Dim myDate As Date
Dim fso As Scripting.FileSystemObject  'For this Sub ColorAndProtectCells() macro to function do this: on VBA Editor [Alt+F11] click --> Tools --> References --> scroll to and find 'Microsoft Scripting Runtime' in the libraries list and check the box next to it and click OK.
Dim sFolder As Scripting.Folder
Dim fil As Scripting.File
Dim fPath As String

Set Dwb = ThisWorkbook
   ' DO NOT CHANGE THE NAME OF THE DEFAULT NAMED 'Daily Prep Summary' worksheet tab without also changing Dwb.Sheets("Daily Prep Summary")... to the newly named worksheet tab name on the line below too; otherwise the macro can't find where to copy/paste the Summary entries!
Set Sws = Dwb.Sheets("Daily Prep Summary")
myDate = Sws.Range("D1").Value

' this assures that the Summary worksheet is set to automatic calculation; by default, Excel sets automatic calculation to all other workbooks when a macro runs (however, slower). If speed is an issue calculation can be set just for column H on each worksheet.
Application.Calculation = xlCalculationAutomatic

'*******************************************************************************************
' these lines force Excel to refresh the screen
Application.ScreenUpdating = True
DoEvents
ActiveSheet.Calculate
ActiveWindow.SmallScroll
Application.ScreenUpdating = False
'********************************************************************************************
'Source folder path is set to the path of workbook having this code... the current active folder with all the Unit Sets of the same contract. To simplify programming, place this summary file in the same folder as the unit set workbooks are located
'   ...or change fPath to a different folder path such as F:\\... if you want to run the macro from another folder location
fPath = Dwb.Path
'********************************************************************************************

Set fso = New Scripting.FileSystemObject
Set sFolder = fso.GetFolder(fPath)

For Each fil In sFolder.Files
    If Left(fso.GetExtensionName(fil), 2) = "xl" And fil.Name <> Dwb.Name And Left(fil.Name, 1) <> "~" Then
'        Workbooks.Open fil.Path, UpdateLinks:=True
        Set Swb = ActiveWorkbook
        For Each ws In Swb.Worksheets
            If ws.Name <> Sws.Name Then
                ws.Unprotect Password:=1038
                DoEvents
                lr = ws.Cells(Rows.Count, 3).End(xlUp).Row  'range = top-left cell I1:last column and row of active region
                If WorksheetFunction.CountIf(ws.Range("H:H"), ">0") > 0 Then       'Possibly use this to select-filter only rows with cells = 'sdate'??
                    With ws.Range("I1:??" & lr)          ' <-- need VBA to populate range here
                        .AutoFilter field:=1, Criteria1:=">0"
                            Set rng = .SpecialCells(xlCellTypeVisible)
                            For Each cell In rng        ' <-- equal to 'sdate'
                                       'color cell background yellow and set cell Locked = True
                             ActiveSheet.OLEObjects("cell").Object.BackColor = RGB(255, 255, 0) , Selection.Locked = True, .Selection.FormulaHidden = False
                            Next cell
                        .AutoFilter
                    End With
                End If
            ws.Protect Password:=1038
            End If
        Next ws
        Swb.Close False
    End If
    Next fil
 
End Sub
---------------------
To test Sub ColorAndProtect macro, copy all sheets except "Daily Prep Summary" to a new file in the same folder and save it then run macro
Color_Protect-Date-Entries.xlsm
Berry MetzgerLean process improvement consultantAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this to see if this is what you are trying to achieve....

Sub ColorAndProtectCells()
' Macro 9/5/15,with each workbook in active folder except this workbook and with each worksheet: unprotect worksheet; with each worksheet find cells matching 'sdate' cell D1 on the "Summary" tab and..._
' set each cell = 'sdate' with background = yellow ("RGB:255,255,0") AND set cell protection = Yes for each cell = 'sdate', then reprotect each worksheet, End Sub
Dim Dwb As Workbook, Swb As Workbook
Dim Sws As Worksheet, ws As Worksheet
Dim slr As Long, lr As Long, n As Long
Dim rng As Range, cell As Range, dcell As Range
Dim myDate As Date
Dim fso As Scripting.FileSystemObject  'For this Sub ColorAndProtectCells() macro to function do this: on VBA Editor [Alt+F11] click --> Tools --> References --> scroll to and find 'Microsoft Scripting Runtime' in the libraries list and check the box next to it and click OK.
Dim sFolder As Scripting.Folder
Dim fil As Scripting.File
Dim fPath As String

Set Dwb = ThisWorkbook
   ' DO NOT CHANGE THE NAME OF THE DEFAULT NAMED 'Daily Prep Summary' worksheet tab without also changing Dwb.Sheets("Daily Prep Summary")... to the newly named worksheet tab name on the line below too; otherwise the macro can't find where to copy/paste the Summary entries!
Set Sws = Dwb.Sheets("Daily Prep Summary")
myDate = Sws.Range("D1").Value

' this assures that the Summary worksheet is set to automatic calculation; by default, Excel sets automatic calculation to all other workbooks when a macro runs (however, slower). If speed is an issue calculation can be set just for column H on each worksheet.
Application.Calculation = xlCalculationAutomatic

'*******************************************************************************************
' these lines force Excel to refresh the screen
Application.ScreenUpdating = True
DoEvents
ActiveSheet.Calculate
ActiveWindow.SmallScroll
Application.ScreenUpdating = False
'********************************************************************************************
'Source folder path is set to the path of workbook having this code... the current active folder with all the Unit Sets of the same contract. To simplify programming, place this summary file in the same folder as the barge set workbooks are located
'   ...or change fPath to a different folder path such as F:\\... if you want to run the macro from another folder location
fPath = Dwb.Path
'********************************************************************************************

Set fso = New Scripting.FileSystemObject
Set sFolder = fso.GetFolder(fPath)

For Each fil In sFolder.Files
    If Left(fso.GetExtensionName(fil), 2) = "xl" And fil.Name <> Dwb.Name And Left(fil.Name, 1) <> "~" Then
        Workbooks.Open fil.Path, UpdateLinks:=True
        Set Swb = ActiveWorkbook
        For Each ws In Swb.Worksheets
            If ws.Name <> Sws.Name Then
                ws.Unprotect Password:=1038
                DoEvents
                lr = ws.Cells(Rows.Count, 3).End(xlUp).Row  '<--range = top-left cell I1:last row of last column
                  If WorksheetFunction.CountIf(ws.Range("H:H"), ">0") > 0 Then  'Possibly use this to select only rows where H > 0, filter rows then color and protect cells = 'sdate' ?
                    With ws.Range("H1:H" & lr)           'VBA fills in range
                       .AutoFilter field:=1, Criteria1:=">0"
                            Set rng = .SpecialCells(xlCellTypeVisible)
                            For Each cell In rng ' <-- equal to 'sdate'
                                n = WorksheetFunction.Count(cell.Offset(0, 1).Resize(1, 100))
                                If n > 0 Then
                                    For Each dcell In cell.Offset(0, 1).Resize(1, n)
                                        If dcell = myDate Then
                                            dcell.Locked = True
                                            dcell.Interior.Color = vbYellow
                                        End If
                                    Next dcell
                                End If
                               'color cell yellow and set cell Locked = True
                           ' ActiveSheet.OLEObjects("cell").Object.BackColor = RGB(255, 255, 0)  .Selection.Locked = True, .Selection.FormulaHidden = False
                            Next cell
                       .AutoFilter
                    End With
                End If
        '    ws.Protect Password:=1038  ' comment out while developing
            End If
        Next ws
        Swb.Close False
    End If
    Next fil
  
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Berry MetzgerLean process improvement consultantAuthor Commented:
This should do it!  But it did not make any changes to cells.  Not sure just why. I am continuing to explore.
The macro opens workbooks ok and completes without error message.

I am closing this thread as complete and will open a new thread to debug.  Hopefully sktneer you can walk me through a possible fix if I need help.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Sure. Just msg me the link of your new question in that case.
0
Berry MetzgerLean process improvement consultantAuthor Commented:
@sktneer
I am opening another thread.  Your solution does work properly. And thanks for your effort.
But, apparently because each workbook is not saved before the macro continues to the next workbook, the cell changes are not also saved.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.