MS Access - VBA - create new Excel workbook - vba

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

Related

Outlook VBA call to excel causes crash [duplicate]

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.

How to suppress excel large info on clipboard message

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

Modifying a closed excel sheet with VBA

I am trying to open one spredsheet from another so that it isn't in view. I would then like to change the column format of one of the columns to date using the TextToColumns feature. The changes should then be saved and the file closed automatically.
When I run the following it says No data was selected to parse. Any thoughts?
Sub Test()
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open("directory of file")
Set xlWS = xlWB.Worksheets("Sheet 1")
xlWS.Unprotect
xlWS.Columns("F:F").Select
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 4), TrailingMinusNumbers:=True
Set xlWS = Nothing
xlApp.DisplayAlerts = False
xlWB.Close True
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
A bit of research should have given you the result, but I will provide it anyway...
'Since you want the Workbook to be invisible, we have to open it in a new Excel Application
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
xlApp.Visible = False
'Open Workbook from specified path
Set xlWB = xlApp.Workbooks.Open("YOUR FILEPATH HERE")
'Select Worksheet from opened Workbook
Set xlWS = xlWB.Worksheets("YOUR WORKSHEET NAME HERE")
'Do something
'example
xlWS.Name = "Asdf"
'Cleanup
Set xlWS = Nothing
xlWB.Close 'True to save changes, False to discard changes
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
This should get you started...
Sub Test()
Dim wbk As Workbook
'Open the workbook that is closed
Set wbk = Workbooks.Open("C:\OtherWorkbook.xlsx")
'Change the format of the first column
wbk.Worksheets(1).Range("A:A").NumberFormat = "0.00"
'Close the workbook and save changes
wbk.Close True
End Sub

Trying to copy data from several ranges in Excel to MS Word

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

Write data from Access to Excel file

I am trying to use the following code to write data into an excel file
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
objexcel.Visible = True
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Documents.Open("C:\Documents and Settings\TAYYAPP\Desktop\test folder\ERROR REPORT2.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbook.Add
End If
but I'm getting an
runtime error object doesn't support property or method
in the line
Set wbexcel = objexcel.Workbook.Add
I have referenced the Excel object library.
You will need to change this line:
Set wbexcel = objexcel.WorkBooks.Open( _
"C:\Documents and Settings\TAYYAPP\Desktop\test folder\ERROR REPORT2.xls")
Note WorkBooks, not Documents
As For this line Set wbexcel = objexcel.Workbook.Add, wbexcel is defined as a workbook, but the line is an action, so:
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
EDIT:
As an aside, DoCmd.Transferspreadsheet is probably the easiest way of transferring a set of data (query, table) from Access to Excel.
I have got this code which works fine
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Dim objSht As Excel.Worksheet
Dim objRange As Excel.Range
Set objexcel = CreateObject("excel.Application")
objexcel.Visible = True
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\Documents and Settings\TAYYAPP\Desktop\test folder\reports\ERROR REPORT2.xls")
Set objSht = wbexcel.Worksheets("Sheet1")
objSht.Activate
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets("Sheet1")
End If
but I want to add one more check that if the file exists then I want to see if its is populated with values and if so then I want the next set of values to be populated from the end. As of now it is overwriting the existing values