I have ContentControl drop down box in Word. Once I select an item from a Drop Down list I want to search for that in an Excel document and set the row number equal to a variable.
The code below is what I tried but the Columns("G:G").Find part says its not defined.
Sub findsomething(curRow)
Dim rng As Range
Dim rownumber As Long
curPath = ActiveDocument.path & "\"
Call Set_Variable(curPath)
StrWkShtNm = "Chapters"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
Set rng = Columns("G:G").Find(what:=curRow)
rownumber = rng.Row
MsgBox rownumber
' Release Excel object memory
Set xlWkBk = Nothing
Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
While using more than one MS Office application it is a good idea to specify which application you are targeting:
Excel.Application.ThisWorkbook.Sheets(1).Range("A1").Select
this is what ended up working. you set me on the right track with referencing Excel.
Sub findsomething(curRow)
Dim rng As Long
Dim rownumber As Long
curPath = ActiveDocument.path & "\"
Call Set_Variable(curPath)
StrWkShtNm = "Chapters"
MsgBox "curRow = " & curRow
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
With xlApp
.Visible = False
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
With xlWkBk
With .Worksheets(StrWkShtNm)
rng = .Range("G:G").Find(what:=curRow)
MsgBox rng
End With
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
Related
I have more than 200 workbooks in an Folder, and i deletes the empty rows by giving an Range in the code that is Set rng = sht.Range("C3:C50000").
If Column C any cell is empty then delete entire Row. Day by day data is enhancing and below code took nearly half hour to complete the processing. That time limit is also increasing with the data.
I am looking for a way to to do this in couple of minutes or in less time. I hope to get some help.
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Application.ScreenUpdating = FALSE
Application.DisplayAlerts = FALSE
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Do While xFileName <> ""
Set wbk = Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.Sheets
Dim rng As Range
Dim i As Long
Set rng = sht.Range("C3:C5000")
With rng
'Loop through all cells of the range
'Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
'Since cell Is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir
Loop
Application.ScreenUpdating = TRUE
Application.DisplayAlerts = TRUE
End Sub
This is how I would implement my suggestions of
collecting the rows to delete into a single range and deleting after the loop.
opening the workbooks in a hidden window so the user is not disturbed by files opening and closing. (And also a minor speed boost when opening files)
Dynamically defining your search range to fit the data of each file, eliminating wasted time searching blank ranges.
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Dim xlApp As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Set xlApp = CreateObject("Excel.Application." & CLng(Application.Version))
Do While xFileName <> ""
Set wbk = xlApp.Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.Sheets
Dim rng As Range
Dim rngToDelete As Range
Dim i As Long
Dim LastRow as Long
LastRow = sht.Cells.Find("*", SearchDirection:=xlPrevious).Row
Set rng = sht.Range("C3:C" & LastRow)
With rng
'Loop through all cells of the range
'Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
'Since cell Is empty, delete the whole row
If rngToDelete Is Nothing Then
Set rngToDelete = .Item(i)
Else
Set rngToDelte = Union(rngToDelete, .Item(i))
End If
End If
Next i
End With
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir
Loop
xlApp.Quit
Set xlApp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I use CreateObject to create a new excel app, and I use Application.Version so the new excel app is the same as the current one. I have had bad experience using New Excel.Application to create the object because it sometimes gets redirected to an excel 365 demo, or some other version of excel that is installed on the computer but not intended for use.
Try this for quicker row deletion:
Sub Doit()
Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Application.ScreenUpdating = FALSE
Application.DisplayAlerts = FALSE
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
Beep
Exit Sub
End If
xFileName = Dir(xFdItem & "*.xlsx")
Do While xFileName <> ""
Set wbk = Workbooks.Open(xFdItem & xFileName)
For Each sht In wbk.WorkSheets 'Sheets includes chart sheets...
On Error Resume Next 'in case of no blanks
sht.Range("C3:C5000").specialcells(xlcelltypeblanks).entirerow.delete
On Error Goto 0
Next sht
wbk.Close SaveChanges:=True
xFileName = Dir()
Loop
Application.ScreenUpdating = TRUE
Application.DisplayAlerts = TRUE
End Sub
Note though your biggest time sink may still be opening and saving/closing all the files.
Reference Filtered Column
The Function
Option Explicit
Function RefFilteredColumn( _
ByVal ColumnRange As Range, _
ByVal Criteria As String) _
As Range
Const ProcName As String = "RefFilteredColumn"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = ColumnRange.Worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim crg As Range: Set crg = ColumnRange.Columns(1)
Dim cdrg As Range: Set cdrg = crg.Resize(crg.Rows.Count - 1).Offset(1)
crg.AutoFilter 1, Criteria, xlFilterValues
On Error Resume Next
Set RefFilteredColumn = cdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError
ws.AutoFilterMode = False
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Use in Your Code
For Each sht In wbk.Worksheets
' The header row ('C2', not 'C3') is needed when using 'AutoFilter'.
Dim rng As Range: Set rng = sht.Range("C2:C5000")
Dim frg As Range: Set frg = RefFilteredColumn(rng, "")
If Not frg Is Nothing Then
frg.EntireRow.Delete
Set frg = Nothing
' Else ' no blanks
End If
Next sht
I know that this has been hashed over many times but none of the solutions work for me
This runs from MS Access
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Workbooks.Open CurPath & MainProjectName & ".xlsm", True
ExcelApp.Visible = False
ExcelApp.Quit
Set ExcelApp = Nothing
Also, the .xlsm file does the following at the end of the procedure
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
but the .xlsm file remains open hidden somewhere. i see it as an instance, not as an application and the reason i know that the .xlsm file stays open because sometimes the excel VBA window stays open (just the VBA window, not the Excel window) and in there i can see which file's modules are there.
posting all my code
this is the piece that runs from MS Access and opens the xlsm file
Public Function RunLoadFilesTest()
ODBCConnString
RunVariables
Dim Rs2 As DAO.Recordset
Dim TABLENAME As String
Set Rs2 = CurrentDb.OpenRecordset("SELECT * FROM QFilesToExportEMail")
Do Until Rs2.EOF
TABLENAME = Rs2("TableName")
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, TABLENAME, CurPath & MainProjectName & ".xlsm", True
Rs2.MoveNext
Loop
Rs2.Close
Set Rs2 = Nothing
Set ExcelApp = CreateObject("Excel.Application")
Set ExcelWbk = ExcelApp.Workbooks.Open(CurPath & MainProjectName & ".xlsm", True)
ExcelApp.Visible = False ' APP RUNS IN BACKGROUND
'ExcelWbk.Close ' POSSIBLY SKIP IF WORKBOOK IS CLOSED
ExcelApp.Quit
' RELEASE RESOURCES
Set ExcelWbk = Nothing
Set ExcelApp = Nothing
End Function
this is the code of the xlsm file. it opens automatically from the ThisWorkbook module. i removed a lot of the code not to clutter the thread but left every piece that opens a workbook, activates a workbook, closes, etc.
Public Sub MainProcedure()
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.EnableEvents = False
CurPath = ActiveWorkbook.Path & "\"
'this is to deselect sheets
Sheets("QFilesToExportEMail").Select
Sheets("QReportDates").Activate
FormattedDate = Range("A2").Value
RunDate = Range("B2").Value
ReportPath = Range("C2").Value
MonthlyPath = Range("D2").Value
ProjectName = Range("E2").Value
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
CurRowNum = 2
Set CurRange = Sheets("QFilesToExportEMail").Range("B" & CurRowNum & ":B" & LastRow)
For Each CurCell In CurRange
If CurCell <> "" Then
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
FirstRowOfSection = ActiveWorkbook.Worksheets("QFilesToExportEMail").Columns(2).Find(ExcelFileName).Row
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If
If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Workbooks.Add
Else
Workbooks.Open CurPath & TemplateFileName
End If
ActiveWorkbook.SaveAs MonthlyPath & FinalExcelFileName
For i = CurRowNum To LastRowOfSection
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
Next i
End If
Windows(FinalExcelFileName).Activate
Sheets(SheetToSelect).Select
ActiveWorkbook.Save
ActiveWorkbook.Close
If LastRowOfSection >= LastRow Then
Exit For
End If
Next
Set CurRange = Sheets("QFilesToExportEMail").Range("A2:A" & LastRow)
For Each CurCell In CurRange
If CurCell <> "" Then
CurSheetName = CurCell
If CheckSheet(CurSheetName) Then
Sheets(CurSheetName).Delete
End If
End If
Next
Sheets("QFilesToExportEMail").Delete
Sheets("QReportDates").Delete
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
The underlying process remains since the workbook object was not fully released like you did with the app object. However, this requires you to assign the workbook object in order to release later.
Dim ExcelApp As object, ExcelWbk as Object
Set ExcelApp = CreateObject("Excel.Application")
Set ExcelWbk = ExcelApp.Workbooks.Open(CurPath & MainProjectName & ".xlsm", True)
ExcelApp.Visible = False ' APP RUNS IN BACKGROUND
'... DO STUFF
' CLOSE OBJECTS
ExcelWbk.Close
ExcelApp.Quit
' RELEASE RESOURCES
Set ExcelWbk = Nothing
Set ExcelApp = Nothing
This is true for any COM-connected language like VBA, including:
Python: WIN32COM saving/exporting multiple sheets as PDF;
R: How to export an Excel sheet range to a picture, from within R, and
PHP: Converting excel to pdf using PHP
As shown, even open source can connect to Excel externally like VBA and should always release initialized objects in their corresponding semantics.
Consider refactoring of Excel VBA code to for best practices:
Explicitly declare variables and types;
Integrate proper error handling (that without can leave resources running);
Use With...End With blocks and avoid Activate, Select, ActiveWorkbook, and ActiveSheet (that can cause runtime errors);
Declare and use Cell, Range, or Workbook objects and at end uninitialize all Set objects;
Use ThisWorkbook. qualifier where needed (i.e., workbook where code resides).
NOTE: Below is untested. So carefully test, debug especially due to all the names being used.
Option Explicit ' BEST PRACTICE TO INCLUDE AS TOP LINE AND
' AND ALWAYS Debug\Compile AFTER CODE CHANGES
Public Sub MainProcedure()
On Error GoTo ErrHandle
' EXPLICITLY DECLARE EVERY VARIABLE AND TYPE
Dim FormattedDate As Date, RunDate As Date
Dim ReportPath As String, MonthlyPath As String, CurPath As String
Dim ProjectName As String, ExcelFileName As String, FinalExcelFileName As String
Dim TableName As String, TemplateFileName As String
Dim SheetToSelect As String, ExcelSheetName As String
Dim CurSheetName As String
Dim i As Integer, CurRowNum As Long, LastRow As Long
Dim FirstRowOfSection As Long, LastRowOfSection As Long
Dim CurCell As Variant, curRange As Range
Dim wb As Workbook
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.EnableEvents = False
CurPath = ThisWorkbook.Path & "\" ' USE ThisWorkbook
With ThisWorkbook.Worksheets("QReportDates") ' USE WITH CONTEXT
FormattedDate = .Range("A2").Value
RunDate = .Range("B2").Value
ReportPath = .Range("C2").Value
MonthlyPath = .Range("D2").Value
ProjectName = .Range("E2").Value
End With
CurRowNum = 2
With ThisWorkbook.Worksheets("QFilesToExportEMail") ' USE WITH CONTEXT
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set curRange = .Range("B" & CurRowNum & ":B" & LastRow)
For Each CurCell In curRange
If CurCell <> "" Then
FirstRowOfSection = .Columns(2).Find(ExcelFileName).Row
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If
' USE WORKBOOK OBJECT
If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Set wb = Workbooks.Add
Else
Set wb = Workbooks.Open(CurPath & TemplateFileName)
End If
wb.SaveAs MonthlyPath & FinalExcelFileName
End If
' USE WORKBOOK OBJECT
wb.Worksheets(SheetToSelect).Select
wb.Save
wb.Close
Set wb = Nothing ' RELEASE RESOURCE
If LastRowOfSection >= LastRow Then
Exit For
End If
Next CurCell
Set curRange = .Range("A2:A" & LastRow)
For Each CurCell In curRange
If CurCell <> "" Then
CurSheetName = CurCell
If CheckSheet(CurSheetName) Then ' ASSUMED A SEPARATE FUNCTION
ThisWorkbook.Worksheets(CurSheetName).Delete
End If
End If
Next CurCell
End With
' USE ThisWorkbook QUALIFIER
ThisWorkbook.Worksheets("QFilesToExportEMail").Delete
ThisWorkbook.Worksheets("QReportDates").Delete
ThisWorkbook.Save
' ThisWorkbook.Close ' AVOID CLOSING IN MACRO
ExitHandle:
' ALWAYS RELEASE RESOURCE (ERROR OR NOT)
Set curCell = Nothing: Set curRange = Nothing: Set wb = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Resume ExitHandle
End Sub
I have 2 sets of ranges; Source file paths and Destination file paths.
I want to loop through each list to open the source file and copy a tab/sheet to the destination file path.
Below is the code I have used to loop through the Source list and copy data from a tab in that workbook and paste it to a named sheet. The copy tab is named in the offset ,1 code below and the paste name will never change.
This step prepares the workbook so i can now copy this tab to a completely separate workbook that I have listed.
Is this possible to do efficiently with a for loop??
Sub RollQuarter()
Dim Wbk As Workbook
Dim Wks As Worksheet
Dim Filepath As String, Filename As String, sStg As String
Dim oDic As Scripting.Dictionary
Dim rng As Range, c As Range
Dim varKey As Variant
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set oDic = New Scripting.Dictionary
oDic.CompareMode = TextCompare
sStg = ""
Set rng = Union(Range("dummy")) 'Source files
For Each c In rng.Cells
If Not oDic.Exists(c.Value) Then
oDic.Add c.Value, c.Offset(, 1).Value
Else
MsgBox "Duplicate Item found", vbInformation, "Error Message"
Exit Sub
End If
Next c
For Each varKey In oDic.Keys
If Len(Dir(varKey)) = 0 Then
If sStg = "" Then
sStg = oDic.Item(varKey)
Else
sStg = sStg & ", " & vbCrLf & oDic.Item(varKey)
End If
Else
On Error Resume Next
Set Wbk = Workbooks.Open(varKey, False)
On Error GoTo 0
If Wbk Is Nothing Then
Else
With Wbk
.Sheets(oDic.Item(varKey)).Cells.Copy
.Sheets("dummy sheet").Cells.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Save
End With
Wbk.Close False
Set Wbk = Nothing
End If
End If
Next varKey
.....
If Len(sStg) > 0 Then MsgBox "The below files do not exist" & vbCrLf _
& sStg, vbCritical
End Sub
I have written a macro that would bring values of certain field from a word file and insert it in a excel file. On every alternate run the word macro gives an error "object variable or with block variable not set". Please help me.
Sub getWordFormData()
Dim exApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim excelApp As Object
Dim openExcel As Workbook
myFolder = ActiveDocument.Path
If Len((myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
End If
Application.ScreenUpdating = False
Set exApp = CreateObject("Word.Application")
Set myDoc = ActiveWorkbook
Set excelApp = New Excel.Application
Set openExcel = excelApp.Workbooks.Open("F:\VBA Sample projects\word to excel\Proposal_DB.xlsx")
excelApp.Visible = True
excelApp.Range("A1").End(xlDown).Offset(1, 0).Select
Set myDoc = exApp.Documents.Open(FileName:=myFolder & "\" & "TEMPLATE WORD.docx", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With excelApp
.Cells(ActiveCell.Row, 1).Value = myDoc.SelectContentControlsByTag("date").Item(1).Range.Text
.Cells(ActiveCell.Row, 2).Value = myDoc.SelectContentControlsByTag("ProtocolNo.").Item(1).Range.Text
.Cells(ActiveCell.Row, 3).Value = myDoc.SelectContentControlsByTag("Subject").Item(1).Range.Text
'excelApp.Cells(ActiveCell.Row, 4).Value = myDoc.SelectContentControlsByTag("companyname").Item(1).Range.Text
'excelApp.Cells(ActiveCell.Row, 5).Value = myDoc.SelectContentControlsByTag("customer_name").Item(1).Range.Text
'excelApp.Cells(Nextrow.Row, 6).Value = myDoc.SelectContentControlsByTag("total_amount").Item(1).Range.Text
'excelApp.Cells(Nextrow.Row, 7).Value = myDoc.SelectContentControlsByTag("employee_name").Item(1).Range.Text
End With
myDoc.Close SaveChanges:=False
' strFile = Dir()
'Wend
excelApp.Quit
Application.ScreenUpdating = True
'End With
'exApp.Quit
End Sub
Compiled but not tested:
'add a reference to the Microsoft Excel objectl ibary in your VBA project
Sub getWordFormData()
Dim myDoc As Document
Dim myFolder As String, strFile As String
Dim excelApp As Excel.Application
Dim excelWb As Excel.Workbook, rw As Excel.Range
myFolder = ActiveDocument.Path
If Len(myFolder) = 0 Then
MsgBox myFolder & vbCrLf & " Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
'create Excel application and open the workbook
Set excelApp = New Excel.Application
excelApp.Visible = True
Set excelWb = excelApp.Workbooks.Open("F:\VBA Sample projects\word to excel\Proposal_DB.xlsx")
'get the next empty row in the worksheet
With excelWb.Sheets(1) '<< or use a specific sheet name
Set rw = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
End With
'you don't need a separate Word instance to open this document...
Set myDoc = Documents.Open(FileName:=myFolder & "\" & "TEMPLATE WORD.docx", _
ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
rw.Cells(1).Value = myDoc.SelectContentControlsByTag("date").Item(1).Range.Text
rw.Cells(2).Value = myDoc.SelectContentControlsByTag("ProtocolNo.").Item(1).Range.Text
rw.Cells(3).Value = myDoc.SelectContentControlsByTag("Subject").Item(1).Range.Text
myDoc.Close savechanges:=False
excelWb.Close savechanges:=True
excelApp.Quit
End Sub
I am using VBA with an event listener on a specific sub-folder to run a macro when that folder receives an email. It is working perfectly, with one exception. I am setting the objects to listen, but they are getting set back to 'nothing' seemingly randomly, which stops the listeners from 'listening'. Here's the code I am using to set the listeners and trigger the macros:
Public WithEvents myOLItems As Outlook.Folder
Public WithEvents myTDLoanEmails As Outlook.Items
Private Sub Application_Startup()
Set myOLItems = Outlook.Session.GetDefaultFolder(olFolderInbox)
Set myTDLoanEmails = myOLItems.Folders("Trust Loan Collateral Tracking Text Files").Items
End Sub
Private Sub myTDLoanEmails_ItemAdd(ByVal Item As Object)
Call getAttachments
Call runTextToExcel
End Sub
'runTextToExcel' creates an Excel application, opens an Excel file, runs a macro in that file, and then closes the file and the application. I think the error may be stemming from the file/Excel application not closing completely, because if I run the Outlook macro again immediately after completion, it cannot find the Excel file, despite the fact that hasn't moved. This causes an error, which I think may be 'unsetting' the listeners. Is this possible?
If it helps (or you're curious) here are the two subs that are called above:
Private Sub runTextToExcel()
Dim xlApp As Object
Dim oWbk As Workbook
Dim TextToExcelFile As Workbook
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
sFile = "Loan Text Files to Excel Converter_v004.xlsm"
sPath = "K:\Shared\Text to Excel\"
bOpened = False
For Each oWbk In Workbooks
If oWbk.Name = sFile Then bOpened = True
Next oWbk
If bOpened = False Then Workbooks.Open (sPath & sFile)
xlApp.Run "'" & sFile & "'!LoanTextFilesToExcel"
xlApp.DisplayAlerts = False
Workbooks(sFile).Close (True)
xlApp.DisplayAlerts = True
xlApp.Quit
End Sub
Private Sub getAttachments()
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim TDLoanEmails As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set TDLoanEmails = Inbox.Folders("Trust Loan Collateral Tracking Text Files")
For Each Item In TDLoanEmails.Items
If Item.Attachments.Count > 3 Then
If Day(Item.ReceivedTime) = Day(Date) And Month(Item.ReceivedTime) = Month(Date) And Year(Item.ReceivedTime) = Year(Date) Then
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 4) = ".TXT" Then
FileName = "K:\Shared\Text to Excel\Text Files\" & Left(Atmt.FileName, Len(Atmt.FileName) - 4) & "-" & Format(Date, "mmddyyyy") & ".txt"
Atmt.SaveAsFile FileName
End If
Next Atmt
End If
End If
Next Item
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Thanks!
Not sure if it is because of the runTextToExcel But take a backup of your existing runTextToExcel and replace it with this.
I believe you are using Late Binding
Changes made in this code
Object Declared
Object Closed and Released properly
Code
Private Sub runTextToExcel()
Dim xlApp As Object
Dim oWbk As Object, wb As Object
Dim TextToExcelFile As Object '<~~ Are you using this anywhere?
Dim bOpened As Boolean
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
sFile = "Loan Text Files to Excel Converter_v004.xlsm"
sPath = "K:\Shared\Text to Excel\"
bOpened = False
For Each oWbk In xlApp.Workbooks
If oWbk.Name = sFile Then bOpened = True
Next oWbk
If bOpened = False Then Set wb = xlApp.Workbooks.Open(sPath & sFile)
xlApp.Run "'" & sFile & "'!LoanTextFilesToExcel"
xlApp.DisplayAlerts = False
wb.Close (True)
xlApp.DisplayAlerts = True
xlApp.Quit
Set wb = Nothing
Set xlApp = Nothing
End Sub