Export Files

[emir0514]

Hello Everyone,

So I created a VBA that creates a report and saves the file based on what is in cell H5 on the Input page and saves it to the directory that is in cell H15 on the Input page. In cell H5 I can select a company name and there is over 30 company names. Rather than running the macro 30 times, I was wondering if there was a way it can go through all the entire list and save them in the same location as 30 separate .xlsx files. Here is my current code that will run it for 1 company.


The very top part of the code is just some formatting on my sheets which would have to remain the same way for all 30 times it runs it, so maybe loop it somehow? By the way the company names that are in cell H5 are using a Data Validation and the full list can be found in the Sources worksheet H2 to H32. Also what if I were to add a company name? Can we set the paramets for H2 to H100? and then just skip over it if the cell is blank.

Thank you!!

Sub TEST4()
'

Dim rs As Worksheet
    Sheets("BS_Entity").Select
    Range("G10:K10").Select
    ActiveCell.FormulaR1C1 = "=Input!R[-5]C[1]"
    Range("G11").Select
    Sheets("IS_Entity").Select
    Range("G10:K10").Select
    ActiveCell.FormulaR1C1 = "=Input!R[-5]C[1]"
    Range("G11").Select
    Sheets(Array("BS_Entity", "IS_Entity")).Select
    Sheets("IS_Entity").Activate
    Sheets(Array("BS_Entity", "IS_Entity")).Copy
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("IS_Entity").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("C:C").Select
    Application.CutCopyMode = False
    Columns("A:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    Sheets("IS_Entity").Select
    ActiveSheet.Name = "IS"
    Range("A1").Select
    Sheets("BS_Entity").Select
    Columns("A:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Name = "BS"
    Range("A1").Select
    
    
 
    Dim strPath As String
    Dim strFolderPath As String
    strFolderPath = Sheet1.Range("H15").Value
    strPath = strFolderPath & _
        Sheet1.Range("H5").Value & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=strPath
    
    ActiveWorkbook.Close
End Sub