I have already spent too many hours looking for the right answer and every which way I try it doesn't work the way I want it to.
I receive the "Application or Object defined error" referencing the Excel file when I run the following. It compiles just fine, so I am not sure where I went wrong. I need it to pull data from two different places on an Excel sheet, place them in specific defined labels in a Word doc, save it with custom name and continue to do so until the end of the list in Excel. Data begins in A1 and B1 respectively.
Dim oXL As Object
Dim oWB As Object
Dim exWb As String
Dim oSheet As Object
Dim bStartExcel As Boolean
Dim objDoc As Object
Dim fcount As Long
Dim iRow As Integer
exWb = "C:\Documents\Waivers_needed_0926_Take2.xlsx"
On Error Resume Next
'If Excel running use it
Set oXL = GetObject(, "Excel.application")
If Err.Number <> 0 Then 'If Excel isn't running then start it
bStartExcel = True
Set oXL = CreateObject("Excel.Application")
End If
On Error GoTo Err_Handler
'Open the workbook
Set oWB = oXL.Workbooks.Open(FileName:=exWb)
'Process the worksheet
Set oSheet = oXL.ActiveWorkbook.Worksheets(4)
For iRow = 1 to 100
With oSheet.Cells(iRow, 0)
ActiveDocument.Amt_Paid.Caption = .Value
End With
With oSheet.Cells(iRow, 1)
ActiveDocument.Payee.Caption = .Value
End With
'Save Word Document with new name
fcount = fcount + 1
With ActiveDocument
.SaveAs FileName:="C:\Documents\Waivers\" & Split(ActiveDocument.Name, ".")(0) & "_" & Format(Now(), "YYYYMMDD") & "_" & fcount & ".doc"
End With
Next iRow
Exit Sub
Related
The code below is intended to update a specific link (the B2 ref) for all Excel files in a given folder (the B1 ref). There's an additional condition that it will only save the file down if the number of errors is the same before and afterwards.
However, when I run this it crashes Excel without any indication of why:
Sub UpdateLinksWS()
Application.ScreenUpdating = False
Dim locWS, locWB As String
Dim wb, ThisWB As Workbook
Dim oFSO, oFolder, oFiles, oFile As Object
Dim noErrors, i, j As Integer
Dim Links As Variant
'Access the file location with VBA objects
locWS = Worksheets("Sheet").Range("B1").Value
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(locWS)
Set oFiles = oFolder.Files
i = 0
Set ThisWB = ThisWorkbook
'For each file in the path ...
For Each oFile In oFiles
'Set the pathname
locWB = locWS & oFile.Name
Set wb = Workbooks.Open(locWB)
'Counts the number of errors in the workbook before updates
noErrors = ErrorCount(wb)
'Update links and calculate workbook - first checking the link to update or update all links
If ThisWB.Worksheets("Sheet").Range("B2").Value = "" Then
wb.UpdateLink Type:=xlExcelLinks
Else
'Check if the sheet is actually there
Links = wb.LinkSources(xlExcelLinks) 'getLinks(wb)
If Links <> Empty Then
For j = 1 To UBound(Links)
If Links(j) = ThisWB.Worksheets("Sheet").Range("B2").Value Then
wb.UpdateLink Name:=Worksheets("Sheet").Range("B2").Value, Type:=xlExcelLinks
End If
Next j
End If
End If
Application.CalculateFull
'If there's a different number of errors after the updates, close, list the workbook in Errors and don't save, otherwise save
If ErrorCount(wb) = noErrors Then
'Exit and save the changes
Workbooks(oFile.Name).Close SaveChanges:=True
Else
Worksheets("Errors").Cells(2 + i, 2).Value = wb.Name
Workbooks(oFile.Name).Close SaveChanges:=False
i = i + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Function ErrorCount(ByVal wb As Workbook) As Integer
Dim nbErrors As Integer
Dim ws As Worksheet
nbErrors = 0
For Each ws In wb.Worksheets
On Error GoTo NoErrs
nbErrors = nbErrors + ws.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Count
Next
ErrorCount = nbErrors
NoErrs:
Resume Next
End Function
Any ideas are appreciated. Thanks in advance.
I am trying to loop through a number of word documents in a folder, and add some information from the word tables to the excel sheet. Right now I have this:
Private Sub Loop_WordToExcel()
Dim WdApp As Object
Dim wddoc As Object
Dim docName As String
Dim strFile As String
Dim directory As String
directory = "c:\path\to\folder"
strFile = Dir(directory & "*.*")
Set WdApp = CreateObject("Word.Application")
Dim rng As Range
Set rng = Application.InputBox(Prompt:="Enter row", Type:=8)
'Do While strFile <> ""
Set wddoc = WdApp.Documents.Open(Filename:=directory & strFile)
rng.Cells(1) = wddoc.Name
'First Name
wddoc.Tables(1).Cell(1, 3).Range.Copy
rng.Cells(2).PasteSpecial (xlPasteValues)
WdApp.ActiveDocument.Close SaveChanges:=False
strFile = Dir
Loop
End Sub
I have two questions.
1. My first issue is a Run-time error '1004': PasteSpecial method of Range class failed
2. At the end of the loop, how to I advance to the next row for the next word document information to be pasted.
Correct syntax while copying from Word is given, May try
Sub Loop_WordToExcel()
Dim WdApp As Word.Application
Dim WdDoc As Document
Dim docName As String
Dim strFile As String
Dim directory As String
Dim Rng As Range
Dim Offst As Long, Txt As String
directory = "C:\users\user\Desktop\Folder1\" ' Change to your path
strFile = Dir(directory & "*.docx") ' docx extension added to prevent attempt to open other type of files
Set Rng = Application.InputBox(Prompt:="Enter row", Type:=8) '
Set WdApp = CreateObject("Word.Application")
WdApp.Visible = True
Do While strFile <> ""
Set WdDoc = WdApp.Documents.Open(Filename:=directory & strFile)
Rng.Offset(Offst, 0).Value = WdDoc.Name
'First Name
WdDoc.Tables(1).Cell(1, 3).Range.Copy 'will raise error if table& corres cell not exists , My use error handrel
Rng.Offset(Offst, 1).Activate
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False 'Assumed want get name in Column B
'is is suggested to use the below two lines instead of paste special above three lines
'Txt = WdDoc.Tables(1).Cell(1, 3).Range.Text 'will raise error if table& corres cell not exists , My use error handrel
'Rng.Offset(Offst, 1).Value = Txt
WdDoc.Close SaveChanges:=False
Offst = Offst + 1
strFile = Dir
Loop
WdApp.Quit
End Sub
It is always preferred to add reference of Microsoft Word Object library.
I've the below code that I'm using in outlook to download an attachment from a list of emails.
The code works fine for the first iteration of the loop, but on the second iteration it errors with Run-time error '91' Object variable or With block variable not set at the step where it is attempting to save the file to a temporary folder on the desktop (i.e. the line wb.SaveAs FileFormat:=51, FileName:=xlNameAndPath).
From reading the documentation here and some testing, it seems that the issue is actually being caused in the first iteration of the loop by wb.close, this sets wb to nothing, which then causes the error in the second iteration.
If i'm right then my question is how to "Respecify a reference for the object variable"?
Sub SaveExcels()
Dim objNS As Outlook.NameSpace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim objAttachments As Outlook.Attachments
For Each Item In olFolder.Items
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
' Check it contains an attachment
Set objAttachments = oMail.Attachments
lngCount = objAttachments.Count
' Check its from the right company
senderCheck = InStr(oMail.SenderEmailAddress, "company.com")
' Check that it is the right email type
subjectCheck = InStr(oMail.Subject, "TYPE")
' Check whether its the latest weeks data
receivedDate = DateValue(oMail.ReceivedTime)
todaysDate = DateValue(Now())
dateDifference = todaysDate - receivedDate
If lngCount > 0 And senderCheck > 0 And subjectCheck > 0 And dateDifference <= 7 Then
' Get the file name
strFile = objAttachments.Item(1).FileName
' Debug.Print strFile
strFolderpath = "D:\Users\" & Environ("Username") & "\Desktop\temp\"
' Combine with the path to the Temp folder.
strFileIncPath = strFolderpath & strFile
' Debug.Print strFile
' Save the attachment as a file.
objAttachments.Item(1).SaveAsFile strFileIncPath
' Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(strFolderpath).CopyHere oApp.NameSpace(strFileIncPath).Items
' Delete the zip file
Kill strFileIncPath
' Open the excel file
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
xlName = Replace(strFile, ".ZIP", "")
xlNameTemp = xlName & "_00000.xls"
xlNameAndPath = strFolderpath & xlName
Debug.Print xlNameAndPath
xlApp.Workbooks.Open strFolderpath & xlNameTemp
Dim wb As Workbook
Set wb = ActiveWorkbook
' Save as unique name and close
wb.SaveAs FileFormat:=51, FileName:=xlNameAndPath << ERROR
' Get rid of the old excel
Kill strFolderpath & xlNameTemp
' Close the workbook
wb.Close
End If
End If
Next
End Sub
I believe
Dim wb As Workbook
Set wb = xlApp.Workbooks.Open(strFolderpath & xlNameTemp)
will do the job, per the docs. (Not tested -YMMV!)
I'm trying to open an Excel file from Access and do some stuff with It, but code is not stable. Sometimes It works, other times not. Here's how I do this:
Dim FilePath As String
Dim ExcelApp As Excel.Application
FilePath = "C:\Users\Lucky\Desktop\Test.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Workbooks.Open (FilePath)
With ExcelApp
'do some stuff here
End With
ExcelApp.Workbooks.Close
Set ExcelApp = Nothing
I've also noticed that once I run code, Excel starts proccess under Task Manager, that has to be killed manually in order to get code working again. Otherwise I get two types of error with Excel file:
one is that If I click Excel file, It doesn't open, It just flashes for a second and dissapears
and other is that Excel file opens in "read-only" mode...
So I reckon there is some flaw when file is closed in my code. How can I fix this ?
I can't see what's wrong with your code - maybe the path to the desktop?
This is the code I usually use - I've added another function to help choose the file. It uses late binding, so no need to set a reference to Excel - you don't get the IntelliSense and can't use Excel constants such as xlUp - you have to use the numerical equivalent.
Public Sub Test()
Dim oXLApp As Object
Dim oXLWrkBk As Object
Dim oXLWrkSht As Object
Dim vFile As Variant
Dim lLastRow As Long
vFile = GetFile()
Set oXLApp = CreateXL
Set oXLWrkBk = oXLApp.WorkBooks.Open(vFile, False)
Set oXLWrkSht = oXLWrkBk.WorkSheets(1) 'First sheet. Can also use "Sheet1", etc...
lLastRow = oXLWrkSht.Cells(oXLWrkSht.Rows.Count, "A").End(-4162).Row '-4162 = xlUp
MsgBox "Last row in column A is " & lLastRow
oXLWrkBk.Close False
oXLApp.Quit
Set oXLWrkBk = Nothing
Set oXLApp = Nothing
End Sub
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
Function GetFile(Optional startFolder As Variant = -1, Optional sFilterName As String = "") As Variant
Dim fle As Object
Dim vItem As Variant
'''''''''''''''''''''''''''''''''''''''''''
'Clear the file filter and add a new one. '
'''''''''''''''''''''''''''''''''''''''''''
Application.FileDialog(3).Filters.Clear
Application.FileDialog(3).Filters.Add "'Some File Description' Excel Files", "*.xls, *.xlsx, *.xlsm"
Set fle = Application.FileDialog(3)
With fle
.Title = "Select a file"
.AllowMultiSelect = False
If startFolder = -1 Then
.InitialFileName = CurrentProject.Path
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
I have managed to solve my problem. There is nothing wrong with code in my question, except that instead of declaring
Dim ExcelApp As Excel.Application
It's better to use
Dim ExcelApp As Object
But much bigger problem is with code that does changes in Excel, such as this line:
x = Range(Cells(1, i), Cells(Rows.Count, i).End(xlUp)).Value
And correct synthax is:
x = ExcelApp.Range(ExcelApp.Cells(1, i), ExcelApp.Cells(ExcelApp.Rows.Count, i).End(xlUp)).Value 'maybe also better to replace xlUp with -4162
So, whenever you use some code for Excel file from Access, DON'T FORGET to reference everything to Excel object. And ofcourse, before everything, a proper reference must be set in VBA console, in my case Microsoft Office 15.0 library.
I am trying to create For Each loop for a several workbooks; however I am not able to set the workbook name in the array and thus resulted into this. I'm stuck in trying to concatenate the workbook name.
Here's my code:
'Open all .csv file in folder location
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
For Each objFile In objFolder.Files
If InStr(objFile, ".csv") Then
Workbooks.Open (objFile)
End If
Next
' Declare variables
Dim WrkBkPrm As Workbook
Dim WrkBkSrc As Workbook
Dim WrkShtPrm As Worksheet
Dim WrkShtSrc As Worksheet
Dim TextSrc(4) As String
Dim SrcRng As Range
Dim DRng As Range
' Assign values to TextSrc() Array
TextSrc(0) = Cable
TextSrc(1) = Care
TextSrc(2) = MSD
TextSrc(3) = Business
'Set WrkBkPrm and WrkShtPrm values
Set WrkBkPrm = Workbooks("MasterFile" & ".xlsm")
Set WrkShtPrm = WrkBkPrm.Worksheets("Canvas")
'Activate Canvas Sheet
WrkBkPrm.Activate
WrkShtPrm.Select
Application.ScreenUpdating = False
'Start For Each Loop
For Each Src In TextSrc()
Set WrkBkSrc = Workbooks(Src & ".csv")
Set WrkShtSrc = WrkBkSrc.Worksheets(Src)
'Copy loop for 1st section
For i = 2 To 49
For j = 7 To 25
Set SrcRng = WrkShtSrc.Cells(i, j)
Set DRng = WrkShtPrm.Cells(i, j)
If SrcRng <> "" Then
DRng.Value = SrcRng.Value
End If
Next j
Next i
Next Src
Application.ScreenUpdating = True
I'd suggest you work on the file as soon as you get hold of the relevant info you need.
Something like:
Dim wb As Workbook
For Each objFile In objFolder.Files
If InStr(objFile.Name, ".csv") <> 0 Then
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & objFile.Name)
'~~> Do your cool stuff with the opened CSV File
wb.Close False '~~> Close without saving
Set wb = Nothing '~~> Clean up although most of the time not necessary
End If
Next
As for the route you took, for you to use For Each Loop on TxtSrc, you need to declare it as variant.
Something like:
Dim TxtSrc As Variant, Src As Variant
TxtSrc = Array("Cable", "Care", "MSD", "Business")
For Each Src In TxtSrc
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & Src & ".csv")
'~~> More cool stuff here
wb.Close False
Set wb = Nothing
Next
It is important that provide the correct argument for the Workbook Open Method.
You should always include the complete path in string format. HTH.