VBA save and close each workbook before looping to next workbook

Hello Experts,
Using the below macro and Excel 2010, I need to save and close each workbook after each worksheet in the workbook has been processed before looping to  the next file.  This macro protects and changes cell color for each cell matching the date in D1 of the active workbook:
Berry
-----------------
Sub ColorAndProtectCells()

'Macro created 9/9/2015, sktneer, E-E,
'  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 equal to 'sdate' with yellow background ("RGB:255,255,0") AND set cell protection=Yes, then password 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, 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 = True
'********************************************************************************************
'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
                  If WorksheetFunction.CountIf(ws.Range("H:H"), ">0") > 0 Then
                    With ws.Range("H1:H" & lr)
                       .AutoFilter field:=1, Criteria1:=">0"
                            Set rng = .SpecialCells(xlCellTypeVisible)
                            For Each cell In rng
                                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
                                Next cell
                       .AutoFilter
                    End With
                  End If
                ws.Protect Password:=1038
            End If
         Next ws
        Swb.Close False
   ' need to save and close each workbook after all worksheets in each have been processed in order to retain changes upon reopening the workbook
    End If
    Next fil
      ' inform user that macro has ended, that sub-totals for S/Os with same OPER are calculated. Conditional Formatting creates *blue backgrounds* for rows containing a summary QTY (read cell comment at cell F3)
  MsgBox "Daily Prep Parts entries for " & myDate & vbLf & vbLf & "are colored yellow background and protected on all worksheets of all workbooks in current folder" & vbLf & "you're good to go!]" & vbLf & vbLf & vbTab & "                                       Press OK", vbformation + vbExclamation

End Sub
Berry MetzgerLean process improvement consultantAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
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.

Berry MetzgerLean process improvement consultantAuthor Commented:
@sktneer this question is for your attention since you did several iterations in its development
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay you need only one change I think
change line 71 in the below code to Swb.Close True

Sub ColorAndProtectCells()

'Macro created 9/9/2015, sktneer, E-E,
'  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 equal to 'sdate' with yellow background ("RGB:255,255,0") AND set cell protection=Yes, then password 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, 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 = True
'********************************************************************************************
'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
                  If WorksheetFunction.CountIf(ws.Range("H:H"), ">0") > 0 Then
                    With ws.Range("H1:H" & lr)
                       .AutoFilter field:=1, Criteria1:=">0"
                            Set rng = .SpecialCells(xlCellTypeVisible)
                            For Each cell In rng
                                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
                                Next cell
                       .AutoFilter
                    End With
                  End If
                ws.Protect Password:=1038
            End If
         Next ws
        Swb.Close False
   ' need to save and close each workbook after all worksheets in each have been processed in order to retain changes upon reopening the workbook
    End If
    Next fil
      ' inform user that macro has ended, that sub-totals for S/Os with same OPER are calculated. Conditional Formatting creates *blue backgrounds* for rows containing a summary QTY (read cell comment at cell F3)
  MsgBox "Daily Prep Parts entries for " & myDate & vbLf & vbLf & "are colored yellow background and protected on all worksheets of all workbooks in current folder" & vbLf & "you're good to go!]" & vbLf & vbLf & vbTab & "                                       Press OK", vbformation + vbExclamation

End Sub 

Open in new window

Berry MetzgerLean process improvement consultantAuthor Commented:
Hi sktneer
Changing Swb.Close True *DOES* save the file with cell changes. That's a fix.
However, not all cells get changed as seen in the attached .jpg file using a 9/9[/2015] date. I verified that all "9/9" dated cells were of identical dates e.g., all are 9/9/2015 and not 9/9/2014, for instance just to isolate that as a reason for failure.
During debug, and changing screen updating = True, I see cells changing color left to right stopping short of completing all columns of 9/9 cells on the same row; when the macro starts on the next row the same number of columns get changed... but not always as the .jpg screenshot shows.  Some workbooks have 100% completion of '9/9's. I copied '9/9' to a dozen cells to the right of Unit 100 to see if the macro has some limitation on how many columns it will seek and change the 9/9-dated cells and all cells changed except the very last column of that block of '9/9' cells.  
Can you identify the apparent random execution of the macro to change color and protect all the cells?
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
The number of columns for each row is determined by the following line of code..
n = WorksheetFunction.Count(cell.Offset(0, 1).Resize(1, 100))

Open in new window

So n is the count of dates (since dates are number, Count is used) in each visible row from col. I to col. DD.
Do you have dates in visible rows that exceed column DD? If so you can increase the 100 to something which covers all the possible columns with data.

I assume you don't have blanks between dates in a visible row, right?
Berry MetzgerLean process improvement consultantAuthor Commented:
I do not have dates extending as far as Col DD.  At most, there will be 100 columns of entries in a row.
I am attaching a .jpg file (the first evaporated when I used the Preview before send button, to illustrate what is happening...
Cells not colored
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Ah...
That is because you have blanks between the dates which I suspected, so in this case you will need another approach to find the last column used in a visible row.

I will tweak the code accordingly.
Berry MetzgerLean process improvement consultantAuthor Commented:
As to  << I assume you don't have blanks between dates in a visible row, right? >>  Not normally is there ever a skip in entries from L --> R on a visible row.  However, the macro was able to handle a skip as seen in the top of the screenshot, but at the bottom one isolated entry was skipped.  Curious.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay try this....

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'
                                If IsNumeric(cell) Then
                                    n = WorksheetFunction.Match(9 ^ 9, cell.Offset(0, 1).Resize(1, 100)) + 8
                                    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
                                End If
                            Next cell
                       .AutoFilter
                    End With
                End If
            ws.Protect Password:=1038
            End If
        Next ws
        Swb.Close True
    End If
    Next fil
  
End Sub

Open in new window

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:
Hi sktneer,
Perfect!  
Your efforts are, and have been, spot on.  

Thanks a lot for doing fine work, understanding the problem well, and providing quick solutions for this the second of two routines you wrote.
This Color&Protect routine saves someone experienced with Excel about an hour per day, and much more for stand-in employees.  The first CreateSummary macro you previously developed to summarize these date entries has been saving 1.5 clerical hours daily.
Berry
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Berry! Glad I was able to help you in your project. :)
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.