Link to home
Start Free TrialLog in
Avatar of Berry Metzger
Berry MetzgerFlag for United States of America

asked on

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
ASKER CERTIFIED SOLUTION
Avatar of Subodh Tiwari (Neeraj)
Subodh Tiwari (Neeraj)
Flag of India image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Berry Metzger

ASKER

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.
Sure. Just msg me the link of your new question in that case.
@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.