Using loop function in VBA to populate multiple data templates: COMPLEX ISSUE

[joeray1983]

Hello Again,

I have a bit of a predicament here. I am currently designing an organic template (KEY ISSUE HERE) that populates financial information based off a keyword in the template. Essentially you enter a keyword into a specific cell on the tmplate, click a button that identifies the key word, and pulls data from seperate sheets within the excel file that has had all the financial info dumped into it using VBA to pull it from its tables within access.

The issue I'm running into is that I need it to be organic. As in, I change the keyword in the identifier cell and it moves the information populated into a seperate sheet and populates the new information required into a fresh template.

I was relatively new to VBA when I was assigned this project so you can see my problem here as I realize this is quite a complex issue. The code I have written is as following for the data pull:

Option Compare Database
Public Sub SalesAndForecastByProject()
Dim DateStart As Date
Dim DateEnd As Date
Dim OutputFile As String
ActualsStart = 20090101
DateStart = (Month(Now) + 1) & "/1/" & Year(Now)
DateEnd = "12/1/" & Year(Now)
'Set path for the output file
OutputFile = "C:\Users\jray\Desktop\ROIprocessautomation.xls"

DoCmd.SetWarnings False
'---------------------------------------------------------------------------------------------------------------
'Pull Actuals starting from date specified by Actuals Start
MyQuery = "SELECT tblNewProducts.[Project Name], tblNewProducts.[Project Code], (Left(Right([dbo_Rev_Fact].[cal_wk],4),2)+""/1/""+Left([dbo_Rev_Fact].[cal_wk],4)) AS [Date], Sum(dbo_Rev_Fact.Quantity) AS QTY, Sum(dbo_Rev_Fact.ExtPrice) AS Revenue, Sum(dbo_Rev_Fact.ExtCost) AS [Std Cost] INTO ActualsAndForecastByProject "
MyQuery = MyQuery & "FROM (dbo_Dim_Prod INNER JOIN dbo_Rev_Fact ON dbo_Dim_Prod.DimProd_ID=dbo_Rev_Fact.DimProd_ID) INNER JOIN tblNewProducts ON dbo_Dim_Prod.LITM=tblNewProducts.[Part#] "
MyQuery = MyQuery & "WHERE (((dbo_Rev_Fact.cal_wk) > " & ActualsStart & ")) "
MyQuery = MyQuery & "GROUP BY tblNewProducts.[Project Name], (Left(Right([dbo_Rev_Fact].[cal_wk],4),2)+""/1/""+Left([dbo_Rev_Fact].[cal_wk],4)), tblNewProducts.[Project Code] "
MyQuery = MyQuery & "ORDER BY tblNewProducts.[Project Name], (Left(Right([dbo_Rev_Fact].[cal_wk],4),2)+""/1/""+Left([dbo_Rev_Fact].[cal_wk],4)); "
'DoCmd.RunSQL (MyQuery)
'MsgBox MyQuery
'Set the query timeout to 0 so it never times out
On Error Resume Next
CurrentDb.QueryDefs.Delete "qryTestThis"
Set qd = CurrentDb.CreateQueryDef("qryTestThis", MyQuery)
CurrentDb.QueryDefs("qryTestThis").ODBCTimeout = 0
CurrentDb.QueryDefs.Refresh
DoCmd.OpenQuery "qryTestThis"
Set qd = Nothing
CurrentDb.QueryDefs.Delete "qryTestThis"
'---------------------------------------------------------------------------------------------------------------
'Step 1 of pulling Forecast
MyQuery = "SELECT tblNewProducts.[Project Name], tblNewProducts.[Project Code], tblNewProducts.[Part#], "
MyQuery = MyQuery & "[tbl Invoice Date Conversion].[Calendar Month], Sum(PRODDTA_F3460.MFFQT) AS Quantity, "
MyQuery = MyQuery & "[dbo_vw_Pricing.03Dealer] AS RevenuePerUnit, ([dbo_vw_F4105_coledg_07].[COUNCS]/10000) AS CostPerUnit INTO tblFcstStep1 "
MyQuery = MyQuery & "FROM tblNewProducts INNER JOIN ([tbl Invoice Date Conversion] INNER JOIN "
MyQuery = MyQuery & "(((PRODDTA_F3460 LEFT JOIN dbo_vw_Pricing ON (PRODDTA_F3460.MFITM = dbo_vw_Pricing.imitm) "
MyQuery = MyQuery & "AND (PRODDTA_F3460.MFLITM = dbo_vw_Pricing.IMLITM)) "
MyQuery = MyQuery & "LEFT JOIN dbo_vw_F41021_Sum_by_MCU ON (PRODDTA_F3460.MFITM = dbo_vw_F41021_Sum_by_MCU.LIITM) "
MyQuery = MyQuery & "AND (PRODDTA_F3460.MFMCU = dbo_vw_F41021_Sum_by_MCU.LIMCU)) "
MyQuery = MyQuery & "LEFT JOIN dbo_vw_F4105_coledg_07 ON (PRODDTA_F3460.MFITM = dbo_vw_F4105_coledg_07.COITM) "
MyQuery = MyQuery & "AND (PRODDTA_F3460.MFMCU = dbo_vw_F4105_coledg_07.COMCU)) ON [tbl Invoice Date Conversion].[Joolian Date] = PRODDTA_F3460.MFDRQJ) ON tblNewProducts.[Part#] = PRODDTA_F3460.MFLITM "
MyQuery = MyQuery & "WHERE (((dbo_vw_Pricing.MNQ) Is Null Or (dbo_vw_Pricing.MNQ) < 2) And ((PRODDTA_F3460.MFTYPF) = ""BF"")) "
MyQuery = MyQuery & "GROUP BY tblNewProducts.[Project Name], tblNewProducts.[Project Code], tblNewProducts.[Part#], "
MyQuery = MyQuery & "[tbl Invoice Date Conversion].[Calendar Month], [dbo_vw_Pricing.03Dealer], ([dbo_vw_F4105_coledg_07].[COUNCS]/10000) "
MyQuery = MyQuery & "HAVING ((([tbl Invoice Date Conversion].[Calendar Month]) Between #" & DateStart & "# And #" & DateEnd & "#)); "
'Set the query timeout to 0 so it never times out
On Error Resume Next
CurrentDb.QueryDefs.Delete "qryTestThis"
Set qd = CurrentDb.CreateQueryDef("qryTestThis", MyQuery)
CurrentDb.QueryDefs("qryTestThis").ODBCTimeout = 0
CurrentDb.QueryDefs.Refresh
DoCmd.OpenQuery "qryTestThis"
Set qd = Nothing
CurrentDb.QueryDefs.Delete "qryTestThis"
'--------------------------------------------------------------------------------------------------------------
'Step 2 of pulling Forecast and combining it with actuals in ActualsAndForecastByProject table
MyQuery = ""
MyQuery = "INSERT INTO ActualsAndForecastByProject ( [Project Name], [Project Code], [Date], Qty, Revenue, [Std Cost] ) "
MyQuery = MyQuery & "SELECT tblFcstStep1.[Project Name], tblFcstStep1.[Project Code], tblFcstStep1.[Calendar Month] AS [Date], "
MyQuery = MyQuery & "Sum(tblFcstStep1.Quantity) AS Qty, Sum([Quantity]*[RevenuePerUnit]) AS Revenue, "
MyQuery = MyQuery & "Sum([Quantity]*[CostPerUnit]) AS [Std Cost] "
MyQuery = MyQuery & "FROM tblFcstStep1 "
MyQuery = MyQuery & "GROUP BY tblFcstStep1.[Project Name], tblFcstStep1.[Project Code], tblFcstStep1.[Calendar Month] "
MyQuery = MyQuery & "ORDER BY tblFcstStep1.[Project Name], tblFcstStep1.[Calendar Month]; "
DoCmd.RunSQL (MyQuery)
'-------------------------------------------------------------------------------------------------------------
DoCmd.SetWarnings True

DoEvents
'Transfer tables to the output file
'Set up object variables to refer to Excel and objects
Dim Xl As New Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
'Open an instance of Excel, open the workbook
Set Xl = CreateObject("Excel.Application")
Xl.Application.Visible = True
Set XlBook = Xl.Workbooks.Open(OutputFile)
'Define the output worksheet
Set XlSheet = XlBook.Worksheets("actualsforecast")
XlSheet.Cells(1, 1).Value = "'" & Date
'Timestamp

'Copy the table to worksheet starting at cell A3
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("ActualsAndForecastByProject", dbOpenTable)
XlSheet.Range("A4").CopyFromRecordset rs
'Save and Close the file
Set XlSheet = XlBook.Worksheets("New Product ROI")
XlSheet.Range("A1").Select
XlBook.Save
XlBook.Close True
'Close Excel
Xl.Quit

'Clean up
Set rs = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing

End Sub

Public Sub LaborResources()
Dim DateStart As Date
Dim DateEnd As Date
Dim OutputFile As String
'Set path for the output file
OutputFile = "C:\Users\jray\Desktop\ROIprocessautomation.xls"
'--------------------------------------------------------------------------------------------
'DoCmd.RunSQL (MyQuery)
'MsgBox MyQuery
'Set the query timeout to 0 so it never times out
On Error Resume Next
CurrentDb.QueryDefs.Delete "qryTestThis"
Set qd = CurrentDb.CreateQueryDef("qryTestThis", MyQuery)
CurrentDb.QueryDefs("qryTestThis").ODBCTimeout = 0
CurrentDb.QueryDefs.Refresh
DoCmd.OpenQuery "qryTestThis"
Set qd = Nothing
CurrentDb.QueryDefs.Delete "qryTestThis"
'step 1 pulling the intial time file
MyQuery = "SELECT Sum(dbo_TIM_S_fact.Hours) AS SumOfHours, Sum(dbo_TIM_S_fact.ExtRate) AS SumOfExtRate, dbo_TIM_S_fact.Task_id, dbo_TIM_Tasks.Task_Name INTO tbltimoutput"
MyQuery = "FROM dbo_TIM_Tasks INNER JOIN dbo_TIM_S_fact ON dbo_TIM_Tasks.Task_ID=dbo_TIM_S_fact.Task_id"
MyQuery = "GROUP BY dbo_TIM_S_fact.Task_id, dbo_TIM_Tasks.Task_Name;"
'step 2 consolidate data
MyQuery = "SELECT DISTINCT tblNewProducts.[Project Name], tblNewProducts.[Project Code] INTO tblDistinctProject"
MyQuery = "FROM tblNewProducts;"
'step 3 final consolidation
MyQuery = "SELECT DISTINCT tblDistinctProject.[Project Name], tblDistinctProject.[Project Code], Sum(tbltimoutput.SumOfHours) AS SumOfSumOfHours, Sum(tbltimoutput.SumOfExtRate) AS SumOfSumOfExtRate INTO tblTIMFinal"
MyQuery = "FROM tbltimoutput INNER JOIN tblDistinctProject ON tbltimoutput.Task_Name = tblDistinctProject.[Project Name]"
MyQuery = "GROUP BY tblDistinctProject.[Project Name], tblDistinctProject.[Project Code];"
'-------------------------------------------------------------------------------------------------------------
DoEvents
'Transfer tables to the output file
'Set up object variables to refer to Excel and objects
Dim Xl As New Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
'Open an instance of Excel, open the workbook
Set Xl = CreateObject("Excel.Application")
Xl.Application.Visible = True
Set XlBook = Xl.Workbooks.Open(OutputFile)
'Define the output worksheet
Set XlSheet = XlBook.Worksheets("TimData")
XlSheet.Cells(1, 1).Value = "'" & Date 'Timestamp
'Copy the table to worksheet starting at cell A3
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("tbltimfinal", dbOpenTable)
XlSheet.Range("A4").CopyFromRecordset rs
'Save and Close the file
Set XlSheet = XlBook.Worksheets("New Product ROI")
XlSheet.Range("A1").Select
XlBook.Save
XlBook.Close True
'Close Excel
Xl.Quit

'Clean up
Set rs = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing

DoCmd.SetWarnings False
End Sub




This populates all my data and dumps it into the sheets needed to associate the information onto the template.

So, that all being said.... I need excel to recognize that the keyword has changed, have the filters auto select the data in the sheets to match the filter, and then have it spit back onto the template, have that data moved to seperate sheet, and have a fresh template open up to have data entered into it.

Sorry if all that is making your head explode. Imagine what it is doing to a VBA newbie if that helps. It looks something like this --->( )

Thanks in advance!

 

[joeray1983]

bump...still needing help