Sub is affecting the wrong Excel workbook - excel

I wrote this VBA code to generate a report from data in an Access table and dump it into Excel with user friendly formatting.
The code works great the first time. But if I run the code again while the first generated Excel sheet is open, one of my subroutines affects the first workbook instead of the newly generated one.
Why? How can I fix this?
I think the issue is where I pass my worksheet and recordset to the subroutine called GetHeaders that prints the columns, but I'm not sure.
Sub testROWReport()
DoCmd.Hourglass True
'local declarations
Dim strSQL As String
Dim rs1 As Recordset
'excel assests
Dim xlapp As excel.Application
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim tempWS As Worksheet
'report workbook dimentions
Dim intColumnCounter As Integer
Dim lngRowCounter As Long
'initialize SQL container
strSQL = ""
'BEGIN: construct SQL statement {
--this is a bunch of code that makes the SQL Statement
'END: SQL construction}
'Debug.Print (strSQL) '***DEBUG***
Set rs1 = CurrentDb.OpenRecordset(strSQL)
'BEGIN: excel export {
Set xlapp = CreateObject("Excel.Application")
xlapp.Visible = False
xlapp.ScreenUpdating = False
xlapp.DisplayAlerts = False
'xlapp.Visible = True '***DEBUG***
'xlapp.ScreenUpdating = True '***DEBUG***
'xlapp.DisplayAlerts = True '***DEBUG***
Set wb1 = xlapp.Workbooks.Add
wb1.Activate
Set ws1 = wb1.Sheets(1)
xlapp.Calculation = xlCalculationManual
'xlapp.Calculation = xlCalculationAutomatic '***DEBUG***
'BEGIN: Construct Report
ws1.Cells.Borders.Color = vbWhite
Call GetHeaders(ws1, rs1) 'Pastes and formats headers
ws1.Range("A2").CopyFromRecordset rs1 'Inserts query data
Call FreezePaneFormatting(xlapp, ws1, 1) 'autofit formatting, freezing 1 row,0 columns
ws1.Name = "ROW Extract"
'Special Formating
'Add borders
'Header background to LaSenza Pink
'Fix Comment column width
'Wrap Comment text
'grey out blank columns
'END: Report Construction
'release assets
xlapp.ScreenUpdating = True
xlapp.DisplayAlerts = True
xlapp.Calculation = xlCalculationAutomatic
xlapp.Visible = True
Set wb1 = Nothing
Set ws1 = Nothing
Set xlapp = Nothing
DoCmd.Hourglass False
'END: excel export}
End Sub
Sub GetHeaders(ws As Worksheet, rs As Recordset, Optional startCell As Range)
ws.Activate 'this is to ensure selection can occur w/o error
If startCell Is Nothing Then
Set startCell = ws.Range("A1")
End If
'Paste column headers into columns starting at the startCell
For i = 0 To rs.Fields.Count - 1
startCell.Offset(0, i).Select
Selection.Value = rs.Fields(i).Name
Next
'Format Bold Text
ws.Range(startCell, startCell.Offset(0, rs.Fields.Count)).Font.Bold = True
End Sub
Sub FreezePaneFormatting(xlapp As excel.Application, ws As Worksheet, Optional lngRowFreeze As Long = 0, Optional lngColumnFreeze As Long = 0)
Cells.WrapText = False
Columns.AutoFit
ws.Activate
With xlapp.ActiveWindow
.SplitColumn = lngColumnFreeze
.SplitRow = lngRowFreeze
End With
xlapp.ActiveWindow.FreezePanes = True
End Sub

When Cells and Columns are used alone, they refer to ActiveSheet.Cells and ActiveSheet.Columns.
Try to prefix them with the targeted sheet:
Sub FreezePaneFormatting(xlapp As Excel.Application, ws As Worksheet, Optional lngRowFreeze As Long = 0, Optional lngColumnFreeze As Long = 0)
ws.Cells.WrapText = False
ws.Columns.AutoFit
...
End Sub

Okay, I figured out the issue here. I guess I can't use the ".Select" or "Selection." when I'm working with an invisible, non updating workbook. I found that when I changed some code from automated selecting to simply directly changing the value of cells, it worked out.
OLD:
startCell.Offset(0, i).Select
Selection.Value = rs.Fields(i).Name
NEW:
ws.Cells(startCell.Row, startCell.Column).Offset(0, i).Value = rs.Fields(i).Name

Related

SCript does not generate a new workbook for each filtered value

This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub

Copy range and update worksheets in a master workbook

I'm new to VBA and I'm working on a project. I've searched around the internet and managed to put something together using others' examples. The basic idea is that the code copies user-selected data to a single master workbook. This is what I have so far;
Sub SelectOpenCopy()
Dim vaFiles As Variant
Dim i As Long
Dim DataBook As Workbook
Dim DataSheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vaFiles = Application.GetOpenFilename(Title:="Select files", MultiSelect:=True)
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
Set DataBook = Workbooks.Open(FileName:=vaFiles(i))
For Each DataSheet In ActiveWorkbook.Sheets
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next DataSheet
DataBook.Close savechanges:=False
Next i
End If
End Sub
Two problems with this is that:
If I run the code again and select the same files, new worksheets are made in the master workbook and that isn't what I'm going for. If those worksheets already exist, I want them to be updated instead of new ones being made. If it helps to mention, all the workbooks that need to be copied to the master file only have one worksheet each and the worksheet name matches its workbook too.
The code copies all the data, but I only need a set range ("A1:L1000").
There's a lot I don't understand about VBA, so any and all help is really appreciated!
...
Const CopyAddress = "A1:L1000"
Dim MasterSheet As Worksheet, SheetName As String, SheetExists As Boolean
...
For Each DataSheet In DataBook.Worksheets
SheetName = DataSheet.Name
SheetExists = False
For Each MasterSheet In ThisWorkbook.Worksheets
If MasterSheet.Name = SheetName Then
SheetExists = True
Exit For
End If
Next MasterSheet
If SheetExists Then
DataSheet.Range(CopyAddress).Copy MasterSheet.Range(CopyAddress).Cells(1, 1)
Else
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next DataSheet
...
When you run it, don't forget to change the path for the target workbook.
Sub moveData()
'turn off unnecessary applications to make the macro run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim target_wb As Workbook
Dim main_wb As Workbook
Dim file_sheet As Worksheet
Dim exists As Boolean
Dim next_empty_row As Long
Dim R As Range
Dim sheet_name As String
Set main_wb = ThisWorkbook
Set R = _
Application.InputBox("please select the data range:", "Kutools for Excel", , , , , , 8)
sheet_name = ActiveSheet.Name
R.Select
Selection.copy
'workbook path to paste in
Set target_wb = _
Workbooks.Open("/Users/user/Desktop/target.xlsx")
For Each file_sheet In target_wb.Sheets
Application.DisplayAlerts = False
If file_sheet.Name = main_wb.ActiveSheet.Name Then
exists = True
Exit For
Else
exists = False
End If
Next file_sheet
If exists = False Then
target_wb.Sheets.Add.Name = sheet_name
End If
next_empty_row = _
target_wb.Sheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row + 1
target_wb.Sheets(sheet_name).Cells(next_empty_row, 1).PasteSpecial
target_wb.Save
target_wb.Close
'turn on applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub

Run-time error '1004' : PasteSpecial method of Range class failed when attempting to copy a row with matching criteria from one table to another

I have a workbook that stores quite a bit of data. I am trying to import a weekly report, paste it in a table, loop through the imported information and if a row does not match the issue key in a second table, the row needs to be copied and pasted into the second table.
Everything works until it gets to the Paste part of the code. It seems that the selection does not stay copied? I have tried several troubleshooting methods but none have worked.
Sub Get_Data_From_File()
Dim FileToOpen As Variant
Dim DAHelpPulse As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
DAHelpPulse.Sheets(1).Range("A2", Range("M2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Import").Visible = True
ThisWorkbook.Worksheets("Import").Range("A2").PasteSpecial xlPasteValues
DAHelpPulse.Close False
SearchandExtract
End If
Application.ScreenUpdating = False
End Sub
Sub SearchandExtract()
Dim datasheet As Worksheet
Dim ticketsheet As Worksheet
Dim homesheet As Worksheet
Dim issuekey As String
Dim finalrow As Integer
Dim i As Integer
Dim LastRow As Range
Dim TicketReviewTable As ListObject
Set datasheet = Sheet9
Set ticketsheet = Sheet2
Set homesheet = Sheet6
issuekey = ticketsheet.Range("B2").Value
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 2) <> issuekey Then
Range(Cells(i, 1), Cells(1, 13)).Select
Selection.Copy
Sheet2.ListObjects("TicketReview").ListRows.Add
Set TicketReviewTable = Sheet2.ListObjects("TicketReview")
Set LastRow = TicketReviewTable.ListRows(TicketReviewTable.ListRows.Count).Range
With LastRow
LastRow.PasteSpecial xlPasteValues
End With
datasheet.Select
End If
Next i
homesheet.Select
End Sub
I don't think you really need to split this up into two subs - that just means you end up re-defining items already assigned in the first step.
Untested:
Sub Get_Data_From_File()
Dim FileToOpen As Variant, rngCopy As Range, rngPaste As Range
Dim DAHelpPulse As Workbook, tbl As ListObject, issuekey, rw As Range
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", _
FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Application.ScreenUpdating = False
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
With DAHelpPulse.Sheets(1)
Set rngCopy = .Range(.Range("A2"), .Range("M2").End(xlDown))
End With
With ThisWorkbook.Worksheets("Import")
.Visible = True
Set rngPaste = .Range("A2").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
End With
rngPaste.Value = rngCopy.Value
DAHelpPulse.Close False 'no save
Set tbl = Sheet2.ListObjects("TicketReview")
issuekey = Sheet2.Range("B2").Value
For Each rw In rngPaste.Rows
If rw.Cells(2) <> issuekey Then
tbl.ListRows.Add.Range.Value = rw.Value
End If
Next rw
End If
End Sub

Formatting an Excel Worksheet after an ms access export (VBA)

I am trying to export multiple queries from an MS Access (2013) query into a multiple worksheet workbook in Excel (2013). The export process is no problem. This issue is formatting the worksheet(s) after the export. for each worksheet (5), I need to:
Freeze top row
fill in the top row with yellow background
apply a 'filter&sort'...
Each report export has it's own 'section' so, I'll paste just one section.
When the formatting portion of the code starts, I usually get errors such as run-time errors:
'9':Subscript out of range
'1004' Method 'range' of object '_Global' failed.
These errors are really never consistent. Code is below:
Private Sub cmdGeneralReportWithComments_Click()
Me.ReportProcessLb.Visible = True
Me.UpdateTablesLb.Visible = False
'Dim general variables to check that all fields are populated to make the reports
Dim startdatevar As Date
Dim enddatevar As Date
Dim pathtotemplatevar As String
Dim savereporttovar As String
Dim reportnamevar As String
Dim alltogethernow As String
startdatevar = Me.txtStartDate
enddatevar = Me.txtEndDate
pathtotemplatevar = Nz(Me.txtBrowse, "")
savereporttovar = Me.txtToReport
reportnamevar = Me.txtNameTheReport
'alltogethernow = startdatevar + enddatevar + pathtotemplatevar + savereporttovar + reportnamevar
'MsgBox alltogethernow
If startdatevar Like "" Or enddatevar Like "" Or pathtotemplatevar Like "" Or savereporttovar Like "" Or reportnamevar Like "" Then
MsgBox "The dates, report path's and a report path must be entered, please try again :)"
Else
'*************************************************
'Start Report PMCS
'*************************************************
'dim date values
Dim TheStartDate As Date
Dim TheEndDate As Date
'copy the template file and move it and rename it
Dim pathtotemplate As String
Dim pathtoreport As String
pathtotemplate = Me.txtBrowse
pathtoreport = Me.txtToReport
'output the Pmcs report
Dim outputFileName As String
'outputFileName = "C:\Users\travisanor1\Desktop\UTV\Reports\June2017 \SaveTest\GeneralReport_Template.xlsx"
outputFileName = pathtoreport & "\" & Me.txtNameTheReport
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "GeneralReportWithComments_Pmcs", outputFileName, True
'Rename and format the worksheet
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set xls = New Excel.Application
Set wkb = xls.Workbooks.Open(pathtoreport & "\" & Me.txtNameTheReport)
'format
'filter sort on first row
Range("A1:Q1").AutoFilter
'Fill in first row
Rows("1:1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'freeze top row
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
' Set the name of the worksheet
Set wks = wkb.Worksheets("GeneralReportWithComments_Pmcs")
wks.Name = Me.txtStartDateTrim & " to " & Me.txtEndDateTrim & "_PMCS"
wkb.Close True
Set wks = Nothing
Set wkb = Nothing
xls.Quit
Set xls = Nothing
'*************************************************
'End PMCS report
'*************************************************
Thanks in advance for any assistance. I have been banging my head on this for 3 days now and I am at wits end.
Thanks!!
Fundamentally, you are not qualifying your Excel objects being foreign inside MS Access. Below lines need to be qualified by the Excel objects you initialize.
Current:
Range("A1:Q1").AutoFilter
Rows("1:1").Select
ActiveWindow.FreezePanes = True
Correct:
wks.Range("A1:Q1").AutoFilter ' EXCEL WORKSHEET METHOD
wks.Rows("1:1").Select ' EXCEL WORKSHEET METHOD
xls.ActiveWindow.FreezePanes = True ' EXCEL APPLICATION METHOD
VBA
Consider the adjusted VBA module complete with error handling
Public Sub ExportExcel()
On Error GoTo ErrHandle
'... incorporate above code ...'
Const outputFileName = pathtoreport & "\" & Me.txtNameTheReport
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
"GeneralReportWithComments_Pmcs", outputFileName, True
'INITIALIZE EXCEL OBJECTS
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set xls = New Excel.Application
Set wkb = xls.Workbooks.Open(outputFileName)
Set wks = wkb.Worksheets("GeneralReportWithComments_Pmcs")
' FILTER/SORT TOP ROW
wks.Range("A1:Q1").AutoFilter
' FILL FIRST ROW
With wks.Rows("1:1").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'FREEZE TOP ROW
wks.Rows("1:1").Activate
With xls.ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
xls.ActiveWindow.FreezePanes = True
'RENAME WORKSHEET
' (WARNING: SPECIAL CHARS LIKE / \ * [ ] : ? NOT ALLOWED IN SHEET NAMES)
wks.Name = Me.txtStartDateTrim & " to " & Me.txtEndDateTrim & "_PMCS"
MsgBox "Successfully exported and formatted workbook!", vbInformation, "OUTPUT"
ExitHandle:
wkb.Close True
Set wks = Nothing: Set wkb = Nothing
xls.Quit
Set xls = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitHandle
End Sub
Public Sub FormatHeader()
ActiveWindow.FreezePanes = True
With ActiveSheet
.Range("A2:G2").Interior.Color = vbYellow
.Range("A2:G2").Font.Bold = True
.Range("A2:G2").AutoFilter
.Columns.AutoFit
End With
End Sub
Change A2:G2 to whatever range you want.
for all sheets:
Public Sub FormatAllHeaders()
Dim sh As Worksheet
For Each sh In Worksheets
ActiveWindow.FreezePanes = True
With sh.Range("A1:G1")
.Interior.Color = vbYellow
.Font.Bold = True
.AutoFilter
.Columns.AutoFit
End With
Next
End Sub
Adding Freeze Top Row
Public Sub FormatAllHeaders()
Dim sh As Worksheet
For Each sh In Worksheets
sh.Activate
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
With sh.Range("A1:G1")
.Interior.Color = vbYellow
.Font.Bold = True
.AutoFilter
.Columns.AutoFit
End With
Next
End Sub

Access multiple exports to existing Excel workbook

I'm using Access 2013 and exporting data to an exisitng Excel 2010 workbook. I'm using the following code (passing the query, worksheet and excel filename). It all works great:
Public Function SendTQ2XLWbSheetSizeRange(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strFilePath is the name and path of the file you want to send this data into.
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler
strPath = strFilePath
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)
ApXL.Visible = True
Set xlWSh = xlWBk.Worksheets(strSheetName)
xlWSh.Activate
xlWSh.Range("A5").Select
For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
xlWSh.Range("A6").CopyFromRecordset rst
xlWSh.Range("1:1").Select
' This is included to show some of what you can do about formatting. You can comment out or delete
' any of this that you don't want to use in your own export.
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
ApXL.Selection.Font.Bold = True
With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
' selects all of the cells
ApXL.ActiveSheet.Cells.Select
' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
' selects the first cell to unselect all cells
xlWSh.Range("A1").Select
rst.Close
Set rst = Nothing
Exit_SendTQ2XLWbSheet:
Exit Function
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_SendTQ2XLWbSheet
End Function
Now I have a requirement to export another query to a different workbook within the same Excel file. The problem is the code above opens the Excel file, so if I then call the procedure again, it then opens an additional read-only copy of the Excel. How do I get around this? It total I will need to perform 3 exports to 3 different worksheets within 1 Excel file. Can anyone help?
I'd use three procedures. The first just identifies which file to open and which query goes on which sheet.
This will place Query1 on Sheet1, Query2 on Sheet2. It uses a ParamArray so you can add as many sheet/query pairs as you like:
Public Sub ProcessExcel()
SendToExcel "<full path to Excel file>", "Sheet1", "Query1", "Sheet2", "Query2"
End Sub
The second procedure sets a reference to Excel, opens the workbook and then starts processing the ParamArray. The sheet name is used to create a reference to the actual sheet which is then passed to the next procedure.
Public Sub SendToExcel(sFilePath As String, ParamArray ShtQry() As Variant)
Dim oXL As Object 'Ref to Excel.
Dim oWB As Object 'Ref to workbook.
Dim x As Long 'General counter
'Get or create reference to Excel.
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Err_Handle
Set oXL = CreateObject("Excel.Application")
End If
On Error GoTo Err_Handle
Set oWB = oXL.Workbooks.Open(sFilePath)
For x = LBound(ShtQry) To UBound(ShtQry) Step 2
SendTQ2XLWbSheetSizeRange oWB.worksheets(CStr(ShtQry(x))), CStr(ShtQry(x + 1))
Next x
Exit Sub
Err_Handle:
End Sub
The final procedure opens the recordset and pastes everything onto the correct sheet:
Public Sub SendTQ2XLWbSheetSizeRange(oWrkSht As Object, sTQName As String)
Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim x As Long
Set db = CurrentDb
Set rst = db.OpenRecordset(sTQName)
With oWrkSht
'Place field headings.
For x = 0 To rst.Fields.Count - 1
.cells(5, x + 1) = rst.Fields(x).Name
Next x
'Place values.
.Range("A6").CopyFromRecordset rst
End With
rst.Close
Set rst = Nothing
Set db = Nothing
End Sub
I've missed out plenty of error checks in the code - ensure the sheet exists, that the array holds sheet/query pairs and lots I haven't even considered.
Note: Not a single Select or Activate in sight - just reference the sheet.
This doesn't sound right: 'export another query to a different workbook within the same Excel file'. How about exporting the contents of different tables to one single Excel file, but placing the results of each table to a separate sheet in the same Excel file. You can easily modify the code to export queries to separate Excel sheets, instead of exporting tables.
Option Compare Database
Option Explicit
Private Sub Command0_Click()
Dim strFile As String
Dim varItem As Variant
strFile = InputBox("Designate the path and file name to export to...", "Export")
If (strFile = vbNullString) Then Exit Sub
For Each varItem In Me.List0.ItemsSelected
DoCmd.TransferSpreadsheet transferType:=acExport, _
spreadsheetType:=acSpreadsheetTypeExcel9, _
tableName:=Me.List0.ItemData(varItem), _
FileName:=strFile
Next
MsgBox "Process complete.", vbOKOnly, "Export"
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim strTables As String
Dim tdf As TableDef
' Reference: MS DAO 3.6
' Properties > All > Row Source Type = Value List
For Each tdf In CurrentDb.TableDefs
If (Left(tdf.Name, 4) <> "MSys") Then
strTables = strTables & tdf.Name & ","
End If
Next
strTables = Left(strTables, Len(strTables) - 1)
Me.List0.RowSource = strTables
End Sub
Add a ListBox to a form, and a button on the same form, and run it that way.
Thanks to everyone for their kind words and suggestions. I've gone with #Cody G. 2nd suggestions and just closed the excel file each time, so just adding
xlWBk.Close True
Set xlWBk = Nothing
ApXL.Quit
Set ApXL = Nothing
Each time.

Resources