How do I streamline this vba code??? (1 Viewer)

[armesca]

The vba code below is what I have come up with to take fields I want from a query I created in Access and paste the results into 10 separate Excel files(region 1-10). I have essentially just repasted this over four more times and changed DLSGP to my other 4 programs names that I am also adding to each regional workbook in excel. I have bolded below the two places where the program needs to be changed for each. I want to be able to simply have one function and rotate out the grant program once the loop has cycled through for each program. Any thoughts or ideas??

Thanks!




Option Compare Database
Option Explicit
'Addresses DLSGP Summary
Function SendToRegion1()
Dim rsOut As DAO.Recordset
Dim objExcel As Object
Dim objWB As Object
Dim objWS As Object
Dim strSQL As String
Dim i As Integer
Dim stRegions As String
Dim filename As String

i = 1

Do While i <= 10
Select Case i
Case 1
stRegions = "Region I"
filename = "Region_ I_PFSR_2011-03-15.xlsx"
Case 2
stRegions = "Region II"
filename = "Region_ II_PFSR_2011-03-15.xlsx"
Case 3
stRegions = "Region III"
filename = "Region_ III_PFSR_2011-03-15.xlsx"
Case 4
stRegions = "Region IV"
filename = "Region_ IV_PFSR_2011-03-15.xlsx"
Case 5
stRegions = "Region V"
filename = "Region_ V_PFSR_2011-03-15.xlsx"
Case 6
stRegions = "Region VI"
filename = "Region_ VI_PFSR_2011-03-15.xlsx"
Case 7
stRegions = "Region VII"
filename = "Region_ VII_PFSR_2011-03-15.xlsx"
Case 8
stRegions = "Region VIII"
filename = "Region_ VIII_PFSR_2011-03-15.xlsx"
Case 9
stRegions = "Region IX"
filename = "Region_ IX_PFSR_2011-03-15.xlsx"
Case 10
stRegions = "Region X"
filename = "Region_ X_PFSR_2011-03-15.xlsx"
End Select

Set objExcel = CreateObject("Excel.Application")

Set objWB = objExcel.Workbooks.Open _
("C:\Documents and Settings\carmes\Desktop\PFSR Region\" & filename)

Set objWS = objWB.Worksheets("DLSGP Summary")

strSQL = "Select [Fiscal Year/Program], [Amount Appropriated], [SumOfAllocation], [Current Obligated Amount], [Draw Downs], [Award Balance], [Current Holds], [Available Funds], [Number of Awards], [SumOfNumber of Awards with Holds], [Pct of Draw Downs], [Pct of Award Balance], [Pct of Current Holds], [Pct of Available Funds], [Pct of Award Balance on Hold], [Pct of Award Balance Available] From [REG - DLSGP2 - Summary] WHERE [Region] = '" & stRegions & "'"


Set rsOut = Application.CurrentDb.OpenRecordset(strSQL)

objWS.Range("A3").CopyFromRecordset rsOut

rsOut.Close

objWB.Save

objWB.Close

Set objWS = Nothing
Set objWB = Nothing

i = i + 1

objExcel.Quit
Set objExcel = Nothing
Loop

Set objWS = Nothing
Set objWB = Nothing



End Function

 

[NigelShaw]

Hi,

here is what i would do

Option Compare Database
Option Explicit
'Addresses DLSGP Summary

Function SendToRegion1()

    Dim rsOut As DAO.Recordset
    Dim objExcel As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim strSQL As String
    Dim i As Integer
    Dim stRegions As String
    Dim filename As String
    [COLOR="Red"]Dim strTrailing As String[/COLOR]
    [COLOR="red"]Dim strRoman As String[/COLOR]
    [COLOR="red"]Dim strRegion As String[/COLOR]
    [COLOR="red"]strTrailing = "_PFSR_2011-03-15.xlsx"[/COLOR]
 
    i = 1
    strRegion = "Region_"
    [COLOR="red"]strRoman = FormatRoman(i)[/COLOR]
     
    Do While i <= 10
 Select Case i
    [COLOR="red"]Case 1 To 10[/COLOR]
    [COLOR="red"]stRegions = "Region " &strRoman[/COLOR]
    [COLOR="red"]filename = strRegion & strRoman & strTrailing[/COLOR]   
End Select
 
 Set objExcel = CreateObject("Excel.Application")
 
        Set objWB = objExcel.Workbooks.Open _
                    ("C:\Documents and Settings\carmes\Desktop\PFSR Region\" & filename)
 
        Set objWS = objWB.Worksheets("[B]DLSGP Summary[/B]")
 
        strSQL = "Select [Fiscal Year/Program]," & _
        "[Amount Appropriated], [SumOfAllocation]," & _
        "[Current Obligated Amount], [Draw Downs]," & _
        "[Award Balance], [Current Holds], [Available Funds]," & _
        "[Number of Awards], [SumOfNumber of Awards with Holds]," & _
        "[Pct of Draw Downs], [Pct of Award Balance], [Pct of Current Holds]," & _
        "[Pct of Available Funds], [Pct of Award Balance on Hold]," & _
        "[Pct of Award Balance Available]" & _
        "FROM" & _
        "[[B]REG - DLSGP2 - Summary[/B]]" & _
        "WHERE [Region] = '" & stRegions & "'"
        
 
        Set rsOut = Application.CurrentDb.OpenRecordset(strSQL)
 
        objWS.Range("A3").CopyFromRecordset rsOut
 
        rsOut.Close
 
        objWB.Save
 
        objWB.Close
        
        Set objWS = Nothing
        Set objWB = Nothing
 
        i = i + 1
 
        objExcel.Quit
        Set objExcel = Nothing
    Loop
 
    Set objWS = Nothing
    Set objWB = Nothing
 
    
    
End Function

'Convert integer to Roman Numeral
[COLOR="YellowGreen"]'Author - Christian d'Heureuse
'Contact - chdh@source-code.biZ[/COLOR]
[COLOR="red"]Public Function FormatRoman(ByVal n As Integer) As String
   If n = 0 Then FormatRoman = "0": Exit Function
      ' There is no roman symbol for 0, but we don't want to return an empty string.
   Const r = "IVXLCDM"              ' roman symbols
   Dim i As Integer: i = Abs(n)
   Dim s As String, p As Integer
   For p = 1 To 5 Step 2
      Dim d As Integer: d = i Mod 10: i = i \ 10
      Select Case d                 ' format a decimal digit
         Case 0 To 3: s = String(d, Mid(r, p, 1)) & s
         Case 4:      s = Mid(r, p, 2) & s
         Case 5 To 8: s = Mid(r, p + 1, 1) & String(d - 5, Mid(r, p, 1)) & s
         Case 9:      s = Mid(r, p, 1) & Mid(r, p + 2, 1) & s
         End Select
      Next
   s = String(i, "M") & s           ' format thousands
   If n < 0 Then s = "-" & s        ' insert sign if negative (non-standard)
   FormatRoman = s
   End Function
[/COLOR]

Regs

N

 

[Red17]

I'd do it this way:

Option Compare Database
Option Explicit
'Addresses DLSGP Summary

Public Type Region
strRegion As String
strFileName As String
End Type

Sub SendToRegion1()

Dim rsOut As DAO.Recordset
Dim objExcel As Object
Dim objWB As Object
Dim objWS As Object
Dim strSQL As String
Dim i As Integer
Dim strExtend As String
Dim arrRegions(1 To 10) As Region

Set objExcel = CreateObject("Excel.Application")

For i = 1 To 10

strExtend = Choose(i, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X")
arrRegions(i).strRegion = "Region " & strExtend
arrRegions(i).strFileName = "Region_" & strExtend & "_PFSR_" & Year(Date) & "-" & Format(Month(Date), "00") & "-" & Format(Day(Date), "00") & ".xlsx"

Debug.Print arrRegions(i).strFileName
strSQL = "Select [Fiscal Year/Program], [Amount Appropriated], [SumOfAllocation] " & _
"[Current Obligated Amount], [Draw Downs], [Award Balance], [Current Holds], " & _
"[Available Funds], [Number of Awards], [SumOfNumber of Awards with Holds], " & _
"[Pct of Draw Downs], [Pct of Award Balance], [Pct of Current Holds], " & _
"[Pct of Available Funds], [Pct of Award Balance on Hold], [Pct of Award Balance Available] " & _
"From [REG - DLSGP2 - Summary] WHERE [Region] = '" & arrRegions(i).strRegion & "'"

Set rsOut = Application.CurrentDb.OpenRecordset(strSQL)

If Not rsOut.EOF And Not rsOut.BOF Then

Set objWB = objExcel.Workbooks.Open _
("C:\Documents and Settings\carmes\Desktop\PFSR Region\" & arrRegions(i).strFileName)

Set objWS = objWB.Worksheets("DLSGP Summary")

objWS.Range("A3").CopyFromRecordset rsOut

rsOut.Close

objWB.Save

objWB.Close

Set objWS = Nothing
Set objWB = Nothing

objExcel.Quit
Set objExcel = Nothing
End If

Next

End Sub

Cheers