I have a database that outputs 4 reports to Excel. These are all in different workbooks.
However I would like to output these all to one template workbook but in different worksheets.
Any help would be appreciated.
Chris
Here you go. I'm using late binding here.
Private Sub OutputToExcel()
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set oExcel = CreateObject("Excel.Application")
End If
On Error GoTo 0
oExcel.Visible = True
Set oBook = oExcel.Workbooks.Add 'default workbook has 3 sheets
Set oSheet = oBook.worksheets(1)
oSheet.Range("A1").Value = "Test " & oSheet.Name
Set oSheet = oBook.worksheets(2)
oSheet.Range("A1").Value = "Test " & oSheet.Name
Set oSheet = oBook.worksheets(3)
oSheet.Range("A1").Value = "Test " & oSheet.Name
Set oSheet = oBook.worksheets.Add
oSheet.Name = "Test Sheet4"
oSheet.Range("A1").Value = "Test " & oSheet.Name
Set oSheet = Nothing
Set oBook = Nothing
Set oExcel = Nothing
End Sub
Related
I'm trying to write a VBA macro from within Word to create an Excel spreadsheet and export data to it. I'm having trouble just creating the new spreadsheet. For the following macro, I get "Object doesn't support this property or method" on the line
Set myWb = myExcel.Workbooks.Add
in the code
Private Sub CreateExcel2()
Dim myExcel As Object
Dim myWb As Object
Set myExcel = CreateObject("Excel.Application")
Set myWb = myExcel.Workbooks.Add
Application.DisplayAlerts = False
myWb.SaveAs FileName:="D:\test\dump.xls"
Application.DisplayAlerts = True
myWb.Close False
Set myWb = Nothing
myExcel.Quit
Set myExcel = Nothing
End Sub
You can try:
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set oExcel = CreateObject("Excel.Application")
End If
On Error GoTo 0
oExcel.visible = true 'to check of excel opens
'try Set myWb = myExcel.Workbooks.Add()
'try Set myWb = oExcel.Workbooks.Open(sPathFile)
What I am trying to do.
I highlight some text in an email then run my macro.
It 'copies' the highlighted text and stores it in variable strText.
Then it creates a file called Artwork List.xlsx if it does not exist and if it exists it opens it.
After that it copies the text into the file in column A row 1 if the lastrow is 1, and if not, it appends to lastrow + 1
My code throws
'Run-time error 424, Object required'
To narrow down, the error should be coming from:
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
or anything related to this line.
Sub copyArts2File()
MsgBox "ok"
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim strText As String
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim strTextArr As Variant
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
'MsgBox strText
lbl_Exit:
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
FileName = "Artwork List.xlsx"
fileDoesExist = Dir("C:\Users\quaer\Desktop\DL Arts\" & FileName) > ""
' Check for existing file
If fileDoesExist Then
' Open Excel file
Set xlBook = xlApp.Workbooks.Open("C:\Users\quaer\Desktop\DL Arts\" & FileName)
Set xlSheet = xlBook.Sheets(1)
Else
' Add Excel file
Set xlBook = xlApp.Workbooks.Add
With xlBook
.SaveAs FileName:="C:\Users\quaer\Desktop\DL Arts\" & FileName
End With
Set xlSheet = xlBook.Sheets(1)
End If
' Do stuff with Excel workbook
Dim i As Integer
Dim lastrow As Long
With xlApp
With xlBook
With xlSheet
strTextArr = Split(strText, "Adding file")
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
MsgBox lastrow
If lastrow = 1 Then
For i = 1 To UBound(strTextArr)
.Range("A" & i).Value = strTextArr(i)
Next i
Else
For i = 1 To UBound(strTextArr)
.Range("A" & (i + lastrow)).Value = strTextArr(i)
Next i
End If
.Close SaveChanges:=True
End With
End With
End With
xlApp.Visible = True
Exit Sub
End Sub
Try replacing this line, lastrow = .Cells(Rows.Count, 1).End(xlUp).Row, with:
lastrow = .Cells(1048576, 1).End(xlUp).Row
or
lastrow = .Cells(Rows.Count +1, 1).End(xlUp).Row
Jeeez this is crazy. I have found the problem finally and got a working code for anyone wanting similar usage. 1st off, I need to add the Microsoft excel add in. So in Outlook VBA, Tools -> references -> check Microsoft Excel 16.0 Object Library. This is to get rid of the 424 object required error, as I was trying to a call a excel built in method I guess. this is the line:
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Pls note that I am calling this macro from Outlook.
After this I faced a couple of other issues.
1. errors such as 424 run time, remote server machine does not exist or is not available.
first time running, it throws this error, 2nd time I click, the problem goes away. This is an issue with non specific use of the app, book and worksheet and so leaves VBA to assign on its own. Lesson learnt, be explicit about every thing.
leaves a copy of excel process even after program ends. This can be seen in task manager. This causes issues because then my excel file is linked to this process and not able to open without either read only or notify. Its locked with the process. So I cannot run again next time.
Anyway. Here is the final code. And I have also changed it to .Range instead of .Cells. I believe it does not matter if I used either but the key culprit is : xlSheet.Rows.Count. Instead of just Rows.Count, explicitly use xlSheet.Rows.Count.
Option Explicit
Sub copyArts2File()
MsgBox "ok"
Dim OutApp As Object, OutMail As Object, olInsp As Object, wdDoc As Object
Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Object
Dim strText As String
Dim strTextArr As Variant
Dim fName As String
Dim fileDoesExist As Boolean
Dim i As Integer
Dim lastrow As Long
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
'MsgBox strText
'Close out all shit
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
lbl_Exit:
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
On Error Resume Next 'Create or use a Excel Application
Set xlApp = GetObject(, "Excel.Application")
If Err.Number > 0 Then Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
xlApp.Visible = False
xlApp.DisplayAlerts = False
fName = "Artwork List.xlsx"
fileDoesExist = Dir("C:\Users\quaer\Desktop\DL Arts\" & fName) > ""
' Check for existing file
If fileDoesExist Then
' Open Excel file if present
Set xlBook = xlApp.Workbooks.Open("C:\Users\quaer\Desktop\DL Arts\" & fName)
Else
' Add Excel file if not present
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs fileName:="C:\Users\quaer\Desktop\DL Arts\" & fName
End If
Set xlSheet = xlBook.Worksheets(1)
' Do stuff with Excel workbook
strTextArr = Split(strText, "Adding file")
lastrow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
If lastrow = 1 Then
For i = 1 To UBound(strTextArr)
xlSheet.Range("A" & i).Value = strTextArr(i)
Next i
Else
For i = 1 To UBound(strTextArr)
xlSheet.Range("A" & (i + lastrow)).Value = strTextArr(i)
Next i
End If
xlBook.SaveAs fileName:="C:\Users\quaer\Desktop\DL Arts\" & fName, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
xlBook.Close (True)
Set xlBook = Nothing
Set xlSheet = Nothing
xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
MsgBox "Done!"
Exit Sub
End Sub
Thanks for the help and suggestions nonetheless.
This question already has answers here:
Test or check if sheet exists
(23 answers)
Closed 3 years ago.
I have set macro for test mails & move them. But if i get an another excel file, where are another sheet names then I get VBA error: subscript out of range.
The error is in this line: Set xlSheet = xlWB.sheets("MySheet1")
Option Explicit
Sub CheckAttachments(olItem As MailItem)
Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\"
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("MyFolder1")
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(LCase(olAttach.FileName), 4) = "xlsx" Then
strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
Chr(32) & olAttach.FileName
olAttach.SaveAsFile strFilename
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to read the data
Set xlWB = xlApp.workbooks.Open(strFilename)
Set xlSheet = xlWB.sheets("MySheet1")
If FindValue(strFindText, xlSheet) Then
olItem.Move myDestFolder
'MsgBox "Value found in " & strFilename
bFound = True
End If
xlWB.Close 0
If bXStarted Then xlApp.Quit
If Not bFound Then Kill strFilename
'Exit For
End If
Next olAttach
End If
End Sub
How can i test the sheet and if it's not exists then exit sub (errorhandling: exit sub) ?
To check if the Sheet exists, you can use a code like this:
On Error Resume Next
Set xlSheet = xlWB.Sheets("MySheet1")
If xlSheet Is Nothing Then
MsgBox "Sheet not found!", vbCritical
Exit Sub
End If
On Error GoTo 0
Hope this helps.
You can adjust your code as follows:
Sub foo()
Dim xlSheet As Object
Dim xlWB As Object
On Error Resume Next
Set xlWB = ThisWorkbook
Set xlSheet = xlWB.Sheets("MySheet2")
On Error GoTo 0
If xlSheet Is Nothing Then
Debug.Print "sheet is missing"
Else
Debug.Print "sheet is not missing"
End If
End Sub
Simply shift your "On Error GoTo 0" statement after you set your xlSheet value, and then add another "If" statement to check if you should continue with the rest of your code.
This should Work for you:
Sub CheckAttachments(olItem As MailItem)
Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\"
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("MyFolder1")
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(LCase(olAttach.FileName), 4) = "xlsx" Then
strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
Chr(32) & olAttach.FileName
olAttach.SaveAsFile strFilename
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to read the data
Set xlWB = xlApp.Workbooks.Open(strFilename)
For Each xlSheet In xlWB.Worksheets
If xlSheet.Name = "MySheet1" Then
Set xlSheet = xlWB.sheets("MySheet1")
Exit For
End If
Next
If xlSheet Is Nothing Then
Exit Sub
End If
If FindValue(strFindText, xlSheet) Then
olItem.Move myDestFolder
'MsgBox "Value found in " & strFilename
bFound = True
End If
xlWB.Close 0
If bXStarted Then xlApp.Quit
If Not bFound Then Kill strFilename
'Exit For
End If
Next olAttach
End If
End Sub
You could use a simple function to check if a sheet name exits:
Function CheckIfSheetExists(Sheetname As String, wb As Workbook) As Boolean
On Error Resume Next
Debug.Print wb.Sheets(Sheetname)
If err.Number <> 0 Then CheckIfSheetExists = False Else CheckIfSheetExists = True
err.clear
End Function
You can call it like so
Sub test()
Dim wbook As Workbook
Dim result As Boolean
Set wbook = Workbooks("Book1")
result = CheckIfSheetExists("Sheet4", wbook)
If result = True Then Msgbox "Sheet exists!"
End Sub
The function will try to print out the name of the specified worksheet within the specified workbook. If this fails, it could not find the worksheet so the function will return False, otherwise it will return True.
I'm trying to run a macro, but when referencing a excel file I have set up already I am getting a run time error and highlights which references my path. I am almost certain that this path is correct because I went to the properties of the excel file and copied the location
Set xlWB = xlApp.Workbooks.Open(strPath)
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
Debug.Print strPath = enviro & "\Documents\multipliers.xls"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Test1")
' Process the message record
Your file is a .xlsx file, not .xls as in your code. Change the following line:
strPath = enviro & "\Documents\multipliers.xls"
to:
strPath = enviro & "\Documents\multipliers.xlsx"
Private Sub doingstuff()
Dim xlWB As Workbook
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
strPath = Environ("USERPROFILE") & "\Desktop" & "\" & "Book2" & ".xlsm"
Set xlWB = Workbooks.Open(strPath)
End Sub
this works fine for me.
I am trying to write a code to open an Excel file and then search through it. Even though, I am having problems just retrieving the number of worksheets in the workbook. I get the error:
424 - VBScript Runtime Error, Object Required
Any thoughts? Here is the small portion of the code I am having problems with:
Dim Shell : Set Shell = WScript.CreateObject( "WScript.Shell" )
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim myworkbook, worksheetcount
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
Set worksheetcount = myworkbook.worksheets.count 'fails
If Err.number <> 0 Then
ShowError()
myworkbook.Close False
End if
Sub ShowError()
WScript.Echo Err.Number & " Srce: " & Err.Source & " Desc: " & Err.Description
Err.Clear
End Sub
The following would do the job.
VBA version
Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
Dim myworkbook As Workbook, worksheetcount As Long
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
worksheetcount = myworkbook.Worksheets.Count
If Err.Number <> 0 Then
ShowError
myworkbook.Close False
End If
VBScript version
Dim Shell: Set Shell = WScript.CreateObject("WScript.Shell")
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel: Set objExcel = CreateObject("Excel.Application")
Dim myworkbook, worksheetcount
Set myworkbook = objExcel.Workbooks.Open("C:\Temp\Test.xlsx")
On Error Resume Next
worksheetcount = myworkbook.Worksheets.Count
If Err.Number <> 0 Then
ShowError
myworkbook.Close False
End If
You had error, because you tried to Set a value to worksheetcount which is not an object. You use Set only to objects.