Hello,
I'm using a snippet of code I found online to loop through a folder and rename each workbook and do other functions in one folder. The issue is the folder name changes each month. I assigned cell D19 to be the month and cell K19 to be the year in the "Hub" workbook. The user inserts the month and year in these cells and another macro creates a new folder named June 2018, July 2018 and so on. Once this is done I run the looping macro from a "Hub" workbook to locate the new folder by adding those cells to the end of the path. This macro is located in a module in the "Hub" workbook.
The path is what I am struggling with. I can set the path to the folder manually but I need the macro to look in the "Hub" workbook to add the value found in cell D19 and K19 to the last part of the path.
I marked the area where I am having issues with a line of XXXXXXXXX. The path listed is the path I entered manually, the path below it is my attempt to set the macro to add the cells value to the end of the path.
Any idea how I can make this work????
I'm using a snippet of code I found online to loop through a folder and rename each workbook and do other functions in one folder. The issue is the folder name changes each month. I assigned cell D19 to be the month and cell K19 to be the year in the "Hub" workbook. The user inserts the month and year in these cells and another macro creates a new folder named June 2018, July 2018 and so on. Once this is done I run the looping macro from a "Hub" workbook to locate the new folder by adding those cells to the end of the path. This macro is located in a module in the "Hub" workbook.
The path is what I am struggling with. I can set the path to the folder manually but I need the macro to look in the "Hub" workbook to add the value found in cell D19 and K19 to the last part of the path.
I marked the area where I am having issues with a line of XXXXXXXXX. The path listed is the path I entered manually, the path below it is my attempt to set the macro to add the cells value to the end of the path.
Code:
Sub LoopAllExcelFilesInFolder8000001()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them.
'Thsi will open each workbook and insert a formula into a cell creating the new name of the workbook.
'SOURCE: www.TheSpreadsheetGuru.com
Dim WB As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
'Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
'With FldrPicker
' .Title = "Select A Target Folder"
'.AllowMultiSelect = False
' If .Show <> -1 Then GoTo NextCode
'myPath = .SelectedItems(1) & "\"
'End With
'In Case of Cancel
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
NextCode:
myPath = "C:\Users\RPlohocky\Desktop\Emailed Temp Files\Lisa Anderson\New Project\8000001\June 2018\"
myPath = ("C:\Users\RPlohocky\Desktop\Emailed Temp Files\Lisa Anderson\New Project\8000001\" & [D19] & " " & [K19])
If myPath = "" Then GoTo ResetSettings
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myfile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myfile <> ""
'Set variable equal to opened workbook
Set WB = Workbooks.Open(Filename:=myPath & myfile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'************************************These procedures happen while WB is open************************************
'Change First Worksheet's Background Fill Blue
'WB.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'Below inserts a formula on the very bottom of the sheet to create a name for the workbook.
Range("A65536").Select
ActiveCell.FormulaR1C1 = "=CONCAT(R[-65535]C,R[-65535]C[3])"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Below deletes the top 6 rows.
Rows("1:6").Select
Selection.Delete Shift:=xlUp
'Below goes to cell A65530 and replaces the slash with a hyphen.
Range("A65530").Select
ActiveCell.Replace What:="/", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Find(What:="/", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
'Below goes to cell A65530 and replaces the colon with a blank.
Range("A65530").Select
ActiveCell.Replace What:=":", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Find(What:="/", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
'**************************************************************************************************************
'Save and Close Workbook
'WB.Close SaveChanges:=True
'*************************These procedures happen after the WB is closed*****************
Dim newFileName As String
newFileName = ActiveSheet.Range("A65530").Value
'Save and Close Workbook
WB.Close SaveChanges:=True
'Rename with new file name
Name myPath & myfile As myPath & newFileName & Mid(myfile, InStrRev(myfile, "."))
'****************************************************************************************
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myfile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End SubAny idea how I can make this work????
