Hi I justed posted a few minutes ago and somone asnwerd my question about excel not closing. I am using access to open a sheet and add a table. Excel won't close which causes issues down the road as when I get the excel object again in another function the sheet I am working with won't open and it won't format it. Here is my code. I thought I was explicit here but maybe I am not. Excel just won't closed.
Public Function BrooksFormatTableBrooks()
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
bfile = "S:\_Reports\Brooks\Tyco-Brooks Receiving Tracking MASTER - "
MyFileName = bfile & Format(Date, "mm-dd-yyyy") & ".xls"
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
Set wb = xlApp.Workbooks.Open(MyFileName)
Set ws = wb.Sheets(1)
ws.Activate
wb.Sheets(1).Name = "RSSR_List"
Set ws = wb.Sheets(1)
ws.Activate
xlApp.ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$312"), , xlYes).Name = _
"RSSR"
ws.Range("A1:F312").Select
DoEvents
ws.Cells.Rows("2:2").Select
xlApp.ActiveWindow.FreezePanes = False
xlApp.ActiveWindow.FreezePanes = True
ws.Columns("A:Z").HorizontalAlignment = xlCenter
ws.Rows("1:1").Font.Bold = True
ws.Rows("1:1").Font.ColorIndex = 1
ws.Rows("1:1").Interior.ColorIndex = 15
ws.Cells.Font.Name = "Calbri"
ws.Cells.Font.Size = 8
ws.Cells.EntireColumn.AutoFit
ws.Cells.EntireRow.AutoFit
xlApp.Cells.Borders.LineStyle = xlContinuous
xlApp.Cells.Borders.Weight = xlThin
xlApp.Cells.Borders.ColorIndex = 0
ws.Cells.Rows("1:1").Select
wb.CheckCompatibility = False
wb.Save
wb.CheckCompatibility = True
wb.Close SaveChanges:=True
xlApp.Quit
Set xlApp = Nothing
Set wb = Nothing
Set ws = Nothing
MsgBox "Table Add"
End Function
Replace Range("$A$1:$F$312") with ws.Range("$A$1:$F$312") or else you will still have a reference to an Excel Application object that won't be destroyed until you exit MSAccess.
Related
For the purpose of sales department I have a query that tracks previous price points and calculates margins. I would like to export this info to Excel to create a combo chart to make the information more visual. I've found some sample code on another site, but it doesn't quite do everything I need. I've used the macro recorder to come up with my desire code, but it uses different methods than my sample code. Can anyone help me to combine the following codes to come up with Combo Charts via VBA?
'sample code below
Private Sub Command201_Click()
Option Compare Database
Private Const conQuery = "qryTopTenProducts"
Private Const conSheetName = "Top 10 Products"
Private Sub Command201_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' Create Excel Application object.
Set xlApp = New Excel.Application
' Create a new workbook.
Set xlBook = xlApp.Workbooks.Add
' Get rid of all but one worksheet.
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' Capture reference to first worksheet.
Set xlSheet = xlBook.ActiveSheet
' Change the worksheet name.
xlSheet.Name = conSheetName
' Create recordset.
Set rst = New ADODB.Recordset
rst.OPEN _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' Copy field names to Excel.
' Bold the column headings.
With .Cells(1, 1)
.Value = rst.Fields(0).Name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).Name
.Font.Bold = True
End With
' Copy all the data from the recordset
' into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data.
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,##0"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xlComboColumnClusteredLine
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
Name:=conSheetName
End With
' Setting the location loses the reference, so you
' must retrieve a new reference to the chart.
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
' Display the Excel chart.
xlApp.Visible = True
ExitHere:
On Error Resume Next
' Clean up.
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "Error in CreateExcelChart"
Resume ExitHere
End Sub
'macro recorded code
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("'PART TARGET'!$A$1:$E$5")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlLine
ActiveChart.FullSeriesCollection(4).AxisGroup = 1
ActiveChart.FullSeriesCollection(5).ChartType = xlLine
ActiveChart.FullSeriesCollection(5).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(4).AxisGroup = 2
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
The problem breaks into two parts. Exporting the data to Excel and then having Excel create a Combo Chart. If you are creating the Excel file you can use Access's Export Data Wizard to create a saved export of almost anything in access. Then its a simple call to:
DoCmd.RunSavedImportExport "Export-MyTabletoExcel"
If you already have an Excel File with a macro for creating the chart from where the data goes then you can create the chart by simply calling the macro from Access
runExcelMacro "C:\Users\bubblegum\Desktop\test2.xlsm", "CreateComboChart"
Public Sub runExcelMacro(wkbookPath, macroName)
'adapted from https://access-excel.tips/run-excel-macro-from-access-vba/
Dim XL As Object
Set XL = CreateObject("Excel.Application")
With XL
.Visible = False
.displayalerts = False
.Workbooks.Open wkbookPath
.Run macroName
.ActiveWorkbook.Close (True)
.Quit
End With
Set XL = Nothing
End Sub
But if you have to create the Excel file it will not have a Macro yet so it is best to create that macro in Excel then translate it to Access vba:
Sub CreateComboChart()
' CreateComboChart Macro
Range("B1:D7").Select
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("Table4!$B$1:$D$7")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
End Sub
became:
Public Sub CreateComboChartinExcel()
'Required: Tools > Refences: Add reference to Microsoft Excel Object Library
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:\Users\bubblegum\Desktop\test.xlsm")
Set xlSheet = xlBook.ActiveSheet
xlSheet.Range("B1:D7").Select
xlSheet.Shapes.AddChart2(201, xlColumnClustered).Select
Set xlChart = xlBook.ActiveChart
xlChart.SetSourceData Source:=xlSheet.Range("B1:D7")
xlChart.FullSeriesCollection(1).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(1).AxisGroup = 1
xlChart.FullSeriesCollection(2).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(2).AxisGroup = 1
xlChart.FullSeriesCollection(3).ChartType = xlLine
xlChart.FullSeriesCollection(3).AxisGroup = 1
xlBook.Save 'surprisingly important
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Finally, the Access Export Wizard neither lets you append the exported data to the Excel file or lets you see the VBA. So if you want to paste to an Excel file you have to either use Docmd.TransferSpreadsheet or loop through the Access tables and copy and paste to excel. I show Docmd:
Public Sub TransferTable()
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "myTable", "C:\Users\bubblegum\Desktop\test.xlsx"
End Sub
i use the following VBA-function to read an Excel-file and "create" a new workbook to save this as CSV-file.
This works fine when i run this function for the first time.
Will i run this again it will not open a new workbook (no Errors returned) and i have to close MS Access and then i call this function again.
Has somebody an idea what i'm doing wrong?
public function fctImportExcel ()
Dim objExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim wbCSV As Excel.Workbook
Dim wsExcel As Excel.Worksheet
Dim wsCSV As Excel.Worksheet
Set objExcel = New Excel.Application
Set wbExcel = objExcel.Workbooks.Open("filepath")
Set wsExcel = wbExcel.Sheets("sheet1")
objExcel.Visible = True
objExcel.DisplayAlerts = False
wsExcel.Range(wsExcel.Cells(i, 7), wsExcel.Cells(i, 25).End(xlDown)).Copy
Set wbCSV = Workbooks.Add
Set wsCSV = wbCSV.Sheets("sheet")
wsCSV.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
objExcel.CutCopyMode = False
wbCSV.SaveAs FileName:="workbook.csv", FileFormat:=xlCSV, CreateBackup:=False
wbCSV.Close acSaveNo
Set wsCSV = Nothing
Set wbCSV = Nothing
objExcel.DisplayAlerts = True
wbExcel.Close acSaveNo
objExcel.CutCopyMode = False
objExcel.Quit
Set wsExcel = Nothing
Set wbExcel = Nothing
Set objExcel = Nothing
End Function
You always must be extremely specific with Excel objects. So try:
Set wbCSV = objExcel.Workbooks.Add
and careful to close in reverse order:
wbCSV.Close acSaveNo
Set wsCSV = Nothing
Set wbCSV = Nothing
wbExcel.Close acSaveNo
Set wsExcel = Nothing
Set wbExcel = Nothing
objExcel.DisplayAlerts = True
objExcel.CutCopyMode = False
objExcel.Quit
Set objExcel = Nothing
I am copying data from worksheet ws and am trying to paste just the values back to the original sheet, thus overwriting the original data with plain text. When I close the workbook I get an excel message telling me "There is a large amount of information on the clipboard. Do you want to be able to past this information into another program?" I will never want to do this. I don't want this message to not appear or assume the answer is "No".
Function FindPresenters(MyDate As Date, MyWS As String) As String
'MyDate is in format of 10/3/2016
'MyWS is the target worksheet to find MyDate
Dim GCell As Range
Dim xlApp As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim MyLoop As Integer
Dim Found As Boolean
On Error GoTo ErrorHandler
Set xlApp = CreateObject("Excel.application") 'New Excel.Application
Application.ScreenUpdating = True
xlApp.Visible = True
Set WB = xlApp.Workbooks.Open ("Sched(Others).xlsx")
Set WS = WB.Worksheets("Oct 2016 Training Schedule")
With WS '.UsedRange
'.Cells.Select
.UsedRange.Select
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False 'This should suppress msg, but doesn't
.Range("B2").Select
End With
WS.Activate
Set GCell = WS.Cells.Find(MyDate)
Found = False
For MyLoop = 1 To MaxDayItems 'Find the entrees for the month
Debug.Print GCell.Offset(MyLoop, 0).Text
If Not Found And InStr(1, GCell.Offset(MyLoop, 0).Text, "C.O.") > 0 Then
'Found data
Found = True
FindPresenters = GCell.Offset(MyLoop, 0).Text
MyLoop = MaxDayItems + 1 'Terminate searching
End If
Next MyLoop
Done:
Application.DisplayAlerts = False 'Tried this to suppress the message
WB.Close True 'This is where the Clipboard error appears
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set WS = Nothing
Set WB = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Function
'Error Handling section.
ErrorHandler:
...
GoTo Done
End Function
Because the cells you are copying belong to xlApp (a separate instance of Excel.Application) you will need to make xlApp.CutCopyMode equal false.
xlApp.CutCopyMode = False
I agree with Comintern's comment "You're only pasting values - just write them directly"
It appears that you are simple replacing all the formulas on the worksheet with their values. This can be achieved by simply like this:
WS.UsedRange.Value = WS.UsedRange.Value
I'm playing around with this code snippet, which I found on SO.
Sub Test()
Dim objWord As Object
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Sheets("Contact Information1")
Set ws2 = ThisWorkbook.Sheets("Contact Information2")
'Set ws3 = ThisWorkbook.Sheets("Contact Information3")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
.Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
'.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
End With
Set objWord = Nothing
End Sub
When I look at it, it makes sense. When I run the script, I get an error on this line:
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
The error message is:
Run-type error 13
Type mismatch
1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.
wd.Tables(1).AutoFitBehavior wdAutoFitWindow
Any ideas on how to make this work?
Thanks!
I came up with the script below. It does what I want.
Sub Export_Table_Word()
'Name of the existing Word doc.
'Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim wdbmRange1 As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet1 As Worksheet
Dim rnReport1 As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set WDApp = New Word.Application
'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")
'Delete old fields and prepare to replace with new
Dim doc As Document
Dim fld As Field
Set doc = WDDoc
For Each fld In doc.Fields
fld.Select
If fld.Type = 88 Then
fld.Delete
End If
Next
Set wsSheet = wbBook.Worksheets("Contact Information1")
Set rnReport = wsSheet.Range("BkMark1")
Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information2")
Set rnReport = wsSheet.Range("BkMark2")
Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information3")
Set rnReport = wsSheet.Range("BkMark3")
Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow
'Save and close the Word doc.
With WDDoc
.Save
.Close
End With
'Quit Word.
WDApp.Quit
'Null out your variables.
Set fld = Nothing
Set doc = Nothing
Set wdbmRange = Nothing
Set WDDoc = Nothing
Set WDApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub
I just started using VBA and I've been using a code to merge multiple worksheets into a single workbook, it works fine except for worksheets containing images. In these cases the image won't show in the new workbook created. It appears the box where the image should be with an error message. I use MS Office 2010.
Here follows the code I've been using:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Any idea of what is going on? I'd appreciate any help!
Tks!
just found a workaround that helped!
I just added "Application.ScreenUpdating = True" before closing the source workbook, it takes longer to merge all worsheets, but at least the images are displayed correctly!
Here follows the new code:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
**Application.ScreenUpdating = True**
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Found this workaround here - Option 1!
Tks Dan!