Modify working code - Export Query and Update Worksheets in Excel Template

N

nguyeda

Registered User.
Local time
Today, 04:30
Joined
May 11, 2011
Messages
37
Hello, the code below basically runs some Access Queries, then copies them in to a NEW excel workbook in .XLS.

What I want to do instead is open an existing .XLSM wokrbook delete or update the 7 sheets it creates and replace them with the new query results from access.

I love this code below because it works really well but now I have a new requirement. I have a workbook that has a "dashboard" sheet that looks at the sheets from acccess and summerizes the data. So, I'd like Access to open that "template" excel workbook and delete the old sheets and put in the new ones....

The required sheets to keep are called "Metrics", "Validation" and "Mara"

What I was trying to do for the past few hours was another work around which was to have Access run this code, then excel run some code to import the "dashboard" formulas but I can't get it to copy to another workbook because it links to the OLD workbook.... ugh.

Here is the working code that needs modding:

Code: 
Option Compare Database
 Public Function ExportAdvanced()
 
 Dim strWorksheet As String
 Dim strWorkSheetPath As String
 Dim appExcel As Excel.Application
 
 Dim sht As Excel.Worksheet
 Dim wkb As Excel.Workbook
 Dim Rng As Excel.Range
 Dim strTable As String
 Dim strRange As String
 Dim strSaveName As String
 Dim strPrompt As String
 Dim strTitle As String
 Dim strDefault As String
 
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = True
 
 strTable = "Summary"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Summary"
 strTable1 = "SOH vs BO"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "SOH vs BO"
 
 strTable2 = "Short Alert"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Short Alert"
 
 strTable3 = "Organic Repair"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Organic Repair"
 
 strTable4 = "Awarded Detail"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Awarded Detail"
 
 strTable5 = "Unawarded Detail"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Unawarded Detail"
 
 strTable6 = "Dispose"
 DoCmd.SetWarnings Flase
 DoCmd.OpenQuery "Dispose"
 
 GetWorksheetsPath = "C:\Users\audan2009\Desktop\ITP\"
 strWorkSheetPath = GetWorksheetsPath
 strWorksheet = "SPIDER Results"
 strSaveName = strWorkSheetPath & strWorksheet & ".xls "
 Debug.Print "Worksheet save name" & strSaveName
 
 On Error Resume Next
 
 Kill strSaveName
 
 
 
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable1, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable2, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable3, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable4, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable5, FileName:=strSaveName, _
    hasfieldnames:=True
    
 DoCmd.TransferSpreadsheet transfertype:=acExport, _
    spreadsheettype:=acSpreadsheetTypeExcel9, _
    TableName:=strTable6, FileName:=strSaveName, _
    hasfieldnames:=True
    
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSaveName)
Set wkb = appExcel.ActiveWorkbook
Set sht = appExcel.ActiveSheet
Set sht1 = appExcel.Worksheets(2)
Set sht2 = appExcel.Worksheets(3)
Set sht3 = appExcel.Worksheets(4)
Set sht4 = appExcel.Worksheets(5)
Set sht5 = appExcel.Worksheets(6)
Set sht6 = appExcel.Worksheets(7)

sht.Activate
With sht 'Summary
    
 appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:Z").AutoFit
    appExcel.Columns("A:Z").HorizontalAlignment = xlCenter
    appExcel.Columns("A:Z").VerticalAlignment = xlCenter
End With
sht1.Activate
With sht1 'SOH vs BO
    
   appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:M").AutoFit
    appExcel.Columns("A:M").HorizontalAlignment = xlCenter
    appExcel.Columns("A:M").VerticalAlignment = xlCenter
End With
sht2.Activate
With sht2 'Short Alert
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:T").AutoFit
    appExcel.Columns("A:T").HorizontalAlignment = xlCenter
    appExcel.Columns("A:T").VerticalAlignment = xlCenter
End With
sht3.Activate
With sht3 'Organic Repair
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:R").AutoFit
    appExcel.Columns("A:R").HorizontalAlignment = xlCenter
    appExcel.Columns("A:R").VerticalAlignment = xlCenter
End With
sht4.Activate
With sht4 'Awarded
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:AX").AutoFit
    appExcel.Columns("A:AX").HorizontalAlignment = xlCenter
    appExcel.Columns("A:AX").VerticalAlignment = xlCenter
End With
sht5.Activate
With sht5 'Unawarded
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:AE").AutoFit
    appExcel.Columns("A:AE").HorizontalAlignment = xlCenter
    appExcel.Columns("A:AE").VerticalAlignment = xlCenter
End With
sht6.Activate
With sht6 'Dispose
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
        "Table6"
    appExcel.Range("A1").End(xlDown).Select
    appExcel.ActiveSheet.ListObjects("Table6").TableStyle = "TableStyleMedium2"
    appExcel.Range("A1").End(xlUp).Select
    appExcel.Range("B1") = "SBU"
    appExcel.Columns("A:K").AutoFit
    appExcel.Columns("A:K").HorizontalAlignment = xlCenter
    appExcel.Columns("A:K").VerticalAlignment = xlCenter
End With
sht.Name = "Summary"
sht1.Name = "Inventory vs Backorders"
sht2.Name = "Short Alert"
sht3.Name = "Organic Repair Detail"
sht4.Name = "Award Detail"
sht5.Name = "Unawarded Detail"
sht6.Name = "Dispose"

appExcel.Application.Visible = True
strPrompt = _
    "Enter file name and path for saving worksheet"
strTitle = "File Name"
strDefault = strSaveName
strSaveName = InputBox(prompt:=strPrompt, _
    Title:=strTitle, Default:=strDefault)
    
wkb.SaveAs FileName:=strSaveName
appExcel.Application.Visible = True
 
 
 End Function
 
Instead of removing the file, simply overwrite the sheets?

In some versions Transferspreadsheet seems to "bug out" sometimes, giving an error "cannot expand named range" or something along those lines....

I have a workaround posted here:
http://www.access-programmers.co.uk/forums/showthread.php?t=259994

As I also mentioned in that thread (which I created my frigging self) most of that code I stole somewhere on some forum or somesort... just adjusted it "slightly"
Let me know if you need more help
 
I'm trying it now. I have Office 2007. I added all the libraries but it won't let me run it at all. Doesn't show up as something I can run... did you have that issue?
 
Doesnt show up as something I can run?

What do you mean?
 
You must log in or register to reply here.

Similar threads

B
Solved VBA code which exports data from Access to Excel and then loops through the Excel file
Replies
0
Views
738
BlueFllame
B
P
Export to Excel not working after SetAccessWindow code
Replies
4
Views
1,294
isladogs
isladogs
C
Export 2x Tables to predefined tabs in Excel in single operation
Replies
5
Views
951
camollie
C
P
Error on Range("A1").SpecialCells(xlLastCell))
Replies
6
Views
2,184
pbaldy
pbaldy
P
Apply Table Formatting in Excel Export
Replies
3
Views
982
pastelrain
P

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom