exceljunk

New Member
Joined
Sep 7, 2022
Messages
2
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a main folder on my desktop, lets call it 'C:\Users\Desktop\Update'. Within that folder I have 3 additional folder lets call them 'FY21', 'FY22' and 'FY23'. Within each of those subfolders there are 5 XLSX files. I have created a code for each file based on the subfolder they are in. I am trying to run a single macro that will go through the subfolders and run the codes I've created based on the subfolder and file names.

The files within each subfolder have a consistent partial filename followed by unique numbers that are different each week.


Main folder location > 'C:\Users\Desktop\Update'
Sub folder names > 'FY21', 'FY22' and 'FY23'
Partial Names within EACH subfolder > Apple_1234567890, Oranges_9875342716, Berries_4937405736, Lemons_9283741092, Pears_9362537120

FY21 Apple Macro ran only on file name 'Apple' within FY21 sub folder
FY22 Apple Macro ran only on file name 'Apple' within FY22 sub folder
FY23 Apple Macro ran only on file name 'Apple' within FY23 sub folder

FY21 Oranges Macro ran only on file name 'Oranges' within FY21 sub folder
FY22 Oranges Macro ran only on file name 'Oranges' within FY22 sub folder
FY23 Oranges Macro ran only on file name 'Oranges' within FY23 sub folder

etc.

Below are two (Apple and Orange) of the 5 codes that I would run within the FY21 subfolder. The only difference in codes between FY is the files that are added and the location that it is saved.


VBA Code:

Sub FY21_Apple_SG()

'

' SelfGenApple Macro

'



'

Rows("1:6").Select

Range("A6").Activate

Application.CutCopyMode = False

Selection.Delete Shift:=xlUp

Selection.Insert Shift:=xlDown

Range("A1").Select

ActiveCell.FormulaR1C1 = "Apples FY21"

Range("A2").Select

ActiveCell.FormulaR1C1 = "Apples"

Range("A4").Select

ActiveCell.FormulaR1C1 = "User: Name"

Range("A5").Select

ActiveCell.FormulaR1C1 = "Report Date: 09/13/2022"

Range("A1").Select

With Selection.Font

.Name = "Calibri"

.Size = 14

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

.TintAndShade = 0

.ThemeFont = xlThemeFontNone

End With

Selection.Font.Bold = True

Rows("7:7").Select

Selection.Style = "Normal"

Selection.Font.Bold = True

ActiveWindow.FreezePanes = False

Columns("N:N").Select

Selection.NumberFormat = "@"

Columns("W:W").Select

Selection.Delete Shift:=xlToLeft

Sheets("Parameters").Select

Application.DisplayAlerts = False

ActiveWindow.SelectedSheets.Delete

Application.DisplayAlerts = True



Dim wbk1 As Workbook, wbk2 As Workbook



'add your own file path

fileStr = "\\C:\Users\Desktop\Update\FY21 Good Parameters Tab.xlsx"



Set wbk1 = ActiveWorkbook

Set wbk2 = Workbooks.Add(fileStr)



'wbk2.Sheets("Bridge 1").Copy After:=Workbooks("WorkbookNameYouCopyCodeInto").Sheets(1)

wbk2.Sheets("Parameters").Copy After:=wbk1.Sheets(1)

wbk2.Saved = True





Dim newName As String

newName = “\\C:\Users\Desktop\Update Complete\FY21\” & Replace(ActiveWorkbook.Name, "Apple", "Apple")

ActiveWorkbook.SaveAs Filename:=newName

ActiveWorkbook.Close



Windows("FY21 Good Parameters Tab1").Activate

ActiveWindow.Close

End Sub







Sub FY21_Oranges_SG()

'

' SelfGenOranges Macro

'



'

Rows("1:6").Select

Range("A6").Activate

Selection.Delete Shift:=xlUp

Selection.Insert Shift:=xlDown

Rows("7:7").Select

Selection.Style = "Normal"

Selection.Font.Bold = True

ActiveWindow.FreezePanes = False

ActiveWindow.SmallScroll ToRight:=16

Range("Q7").Select

ActiveCell.FormulaR1C1 = "OrangeNum"

Columns("O:O").Select

Selection.NumberFormat = "@"

Columns("W:W").Select

Selection.Delete Shift:=xlToLeft

Sheets("Parameters").Select

Application.DisplayAlerts = False

ActiveWindow.SelectedSheets.Delete

Application.DisplayAlerts = True

Dim wbk1 As Workbook, wbk2 As Workbook



'add your own file path

fileStr = "\\C:\Users\Desktop\Update\FY21 Good Parameters Tab.xlsx"

Set wbk1 = ActiveWorkbook

Set wbk2 = Workbooks.Add(fileStr)



'wbk2.Sheets("Bridge 1").Copy After:=Workbooks("WorkbookNameYouCopyCodeInto").Sheets(1)

wbk2.Sheets("Parameters").Copy After:=wbk1.Sheets(1)

wbk2.Saved = True



newName = “\\C:\Users\Desktop\Update Complete\FY21\” & Replace(ActiveWorkbook.Name, "Orange", "Orange")



Dim newName As String

newName = “\\C:\Users\Desktop\Update Complete\FY21\” & Replace(ActiveWorkbook.Name, "Orange", "Orange")

ActiveWorkbook.SaveAs Filename:=newName

ActiveWorkbook.Close



Windows("FY21 Good Parameters Tab1").Activate

ActiveWindow.Close



End Sub
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

Forum statistics

Threads
1,212,929
Messages
6,110,741
Members
448,295
Latest member
Uzair Tahir Khan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top