VBA - Loop Through Variables and Save Said Variable in File Name

[jollywood]

Every Monday, I run a report from Access that compiles multiple agents into one workbook with each agent having their own worksheet. Each agent is assigned a number. I need to be able to remove each worksheet and save it to it's own workbook while adding their respective agent number to the file name. I have the first part finished and was thinking I needed a separate sub function in which to call when saving.

How can I loop through each set agent number (from a list I provide within the code) and have that number save to the file path?

Each worksheet is named Agent1, Agent2, Agent3, etc.

Here is my code and agent list so far: (fyi, there can be up to 244 agents)

Sub Sheets_to_Workbooks()


Dim wsCount As Integer
Dim x As Long
Dim LCharacters As String


LCharacters = UCase(Left(ActiveSheet.Name, 3))
wsCount = ActiveWorkbook.Worksheets.Count


For x = 1 To wsCount
    Worksheets(x).Move
    ActiveWorkbook.SaveAs "C:\Users\C11417\Documents\Test\" & "CC_" & LCharacters & "_CRMID_" & Format(Now, "yyyymmdd") & ".xlsx"
    ActiveWorkbook.Close
Next x


End Sub


Sub Lookup_CRM_ID()


Dim CRMID As String


Agent1 = 700770
Agent2 = 700001
Agent3 = 700004
Agent4 = 700007
Agent5 = 700010


End Sub

 

[AlphaFrog]

Here's one way. It uses a Dictionary object to hold your list of agents and their numbers.

[color=darkblue]Sub[/color] Sheets_to_Workbooks()
    
    [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] LCharacters [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] CRMID [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] Dict [color=darkblue]As[/color] [color=darkblue]Object[/color]
    
    [color=darkblue]Set[/color] Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = 1
    Dict("Agent1") = 700770
    Dict("Agent2") = 700001
    Dict("Agent3") = 700004
    Dict("Agent4") = 700007
    Dict("Agent5") = 700010
    
    LCharacters = UCase(Left(ActiveSheet.Name, 3))
    Worksheets.Add After:=Sheets(Sheets.Count) [color=green]'Dummy sheet. Cannot move all worksheets from a workbook[/color]
    ActiveSheet.Name = "LastSheet"
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] Worksheets
        [color=darkblue]If[/color] ws.Name <> "LastSheet" [color=darkblue]Then[/color]
            ws.Move
            [color=darkblue]If[/color] Dict.Exists(ActiveSheet.Name) [color=darkblue]Then[/color] CRMID = Dict(ActiveSheet.Name) [color=darkblue]Else[/color] CRMID = "NA"
            ActiveWorkbook.SaveAs "C:\Users\C11417\Documents\Test\" & "CC_" & LCharacters & "_" & CRMID & "_" & Format(Now, "yyyymmdd") & ".xlsx"
            ActiveWorkbook.Close SaveChanges:=[color=darkblue]True[/color]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] ws
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[jollywood]

Thanks, this works very well! However, all of the file names are using the first 3 letters for the first worksheet in the workbook.

I, slightly, revised the code so that the first 3 letters are inherent to the dictionary value (i.e. AGE_######) instead of having the code find the 3 characters. (I removed the LCharacters variable)

Now my problem is that when saving,the dictionary doesn't call out the name, it just puts an underscore in it's place.

Sub Sheets_to_Workbooks()
    
    Dim ws As Worksheet
    Dim CRMID As String
    Dim Dict As Object
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = 1
    Dict("Achieve_Energy_Solut") = ACH_700770
    Dict("adl_High_Voltage_Inc") = ADL_700001
    Dict("Affiliated_Power_Pur") = AFF_700004
    
    Worksheets.Add After:=Sheets(Sheets.Count) 'Dummy sheet. Cannot move all worksheets from a workbook
    ActiveSheet.Name = "LastSheet"
    
    For Each ws In Worksheets
        If ws.Name <> "LastSheet" Then
            ws.Move
            If Dict.Exists(ActiveSheet.Name) Then CRMID = Dict(ActiveSheet.Name) Else CRMID = "NA"
            ActiveWorkbook.SaveAs "C:\Users\Jarrod\Downloads\Test\" & "CC_" & CRMID & "_" & Format(Now, "yyyymmdd") & ".xlsx"
            ActiveWorkbook.Close SaveChanges:=True
        End If
    Next ws
    
End Sub

 

[jollywood]

Figured it out. I needed to put quotes around my variable names now that they contain text. Thanks again for your help!!!