2007 Macro to Open File, Delete Contents, Save New File

[Flintstone]

I am tasked with the very tedious assignment of updating about 24 separate
Excel 2007 files every week which require:
- Open File of Current Week
- Update Cell B7 with Week Beginning Date
- Update Cell D7 with Week Ending Date
- Delete Contents of Cells A10:L20 which have been updated throughout the
current week
- Save the updated file with a new Name corresponding to the Next Week
Beginning and Ending Dates

The number of files is growing and I need to find a more expeditious method
of updating this very mundane task. I have attempted to write a Macro, but
have not been successful.

 

[Luke M]

Here's an *untested* macro. Note that it requires some modification to fit
your particular situation. Hopefully it at least gives some basic
ideas/guidance.

'===============
Sub UpdateFiles()
Dim StartWeek, EndWeek As Date
Dim OldPath, NewPath, FileName, NewName As String

With Application
..ScreenUpdating = False
..DisplayAlerts = False
End With

'If Sunday is start of week, use weekday arguement of 1
'If Monday is start of week, use weekday arguement of 2
StartWeek = Date + 1 - WorksheetFunction.Weekday(Date, 2)
EndWeek = Date + 7 - WorksheetFunction.Weekday(Date, 2)

'Where are the files to be updated?
OldPath = "C:\Documents and Settings\My Documents\MyFolder\"
'Where are the the new files to be created at? (should be a different spot)
NewPath = "C:\Documents and Settings\My Documents\NewFolder\"

' This line makes sure the path ends with a back slash
If Right(OldPath, 1) <> "\" Then OldPath = OldPath & "\"
If Right(NewPath, 1) <> "\" Then NewPath = NewPath & "\"

FileName = Dir$(OldPath & "*.xls")
Do While Len(FileName) > 0
Workbooks.Open (OldPath & FileName)
Range("B7") = StartWeek
Range("D7") = EndWeek
Range("A10:L29").ClearContents

'Define filename
NewName = Left(FileName, 6) & Format(StartWeek, "yyyymmdd") & _
Format(EndWeek, "yyyymmdd") & ".xls"

Workbooks(FileName).SaveAs NewPath & NewName
Workbooks(NewName).Close

FileName = Dir$()
Loop

With Application
..DisplayAlerts = True
..ScreenUpdating = True
End With

End Sub
'======================

 

[Flintstone]

Thanks Luke. . . You are a lot faster than me. This will take a little bit
of time for me to work though, but I will keep you posted.