I'm trying to make a VBA macro where You can save each slide with Different Files names, the value of each File Name will come from a specific column of Excel file.
Here's the code that I've been trying so far..
Dim oWB As Object
Dim oXL As Object
Dim xlWS As Object
Dim strFile As String
Dim FName As String
Dim xlColumn As String
Dim getName As String
Dim r As Long
Dim m As Long
' Open Excel File
Set oXL = CreateObject("Excel.Application")
strFile = oXL.GetOpenFilename("Excel Worksheets (*.xlsx),*.xlsx", , "Select Excel file")
If strFile = "False" Then
Beep
Exit Sub
End If
On Error Resume Next
Set oWB = GetObject(Class:="Excel.Application")
If oWB Is Nothing Then
Set oWB = CreateObject(Class:="Excel.Application")
If oWB Is Nothing Then
Beep
Exit Sub
End If
End If
On Error GoTo 0 ' ErrHandler
oWB.Visible = msoCTrue
xlColumn = CStr(InputBox("What Column of Worksheet?", "Column Designation"))
Set xlWS = oWB.Workbook.Open(strFile, , , msoFalse)
m = oWB.Range("A" & Rows.Count).End(xlUp).Row
For r = m To 2 Step -1
FName = oWB.worksheets("Sheet1").Range(xlColumn & r).Value
Next r
While running the macro I'm getting an error:
Application defined or object defined error
Set xlWS = oWB.worksheets.Open(strFile, , , msoFalse)
Related
I want to export data from selected Outlook emails to a workbook. Each email's data (subject, body, etc.) should be stored in a different worksheet.
I'm trying to edit this macro because it is almost what I need—and especially the part of olFormatHTML and WordEditor—because of split.
The idea is
Select multiple emails in Outlook
Open file path
Data for each email selected will be stored in a single worksheet from file opened
The issue with the macro is in this third part
From the selected items, the macro does a loop and just takes the first email selected,
The data is stored in different workbooks; it should be stored in the same workbook that I opened.
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Set itm = GetCurrentItem() 'A)I think the issuefrom selecting 1 item is located here
'|||||||||||||||||||||||||||||||||||||||||
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile) 'B) tried to move it to the beginning and macro doesn't work
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i) 'B)emails in diferrent sheet but no same workbook
Next i
'------------------------------------------------------
Next x
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
End Function
I made an update to this macro
as macro do loop in For x it open the file x times,
and then close it and open again instead of working on the first workbook opened
but the macro leaves open instances
here is the current code
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Dim objApp As Outlook.Application
Dim GetCurrentItem As Object
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(x)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
'-----------------------------------------------
Set itm = GetCurrentItem
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
'de lo contrario, se crea un Reply del correo en formato HTML
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile)
xlApp.Windows("Macro.xlsm").Activate
'Set wb = ActiveWorkbook
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i)
Next i
xlApp.Windows("Macro.xlsm").Close SaveChanges:=True
xlApp.Workbook.Close SaveChanges:=False
'------------------------------------------------------
Next x
'------------------------------------------------------
'the instances should closed but not working, instances are empty
For Each wb In xlApp
wb.Close SaveChanges:=False
Next
End Sub
done, I added xlApp.Quit after saving files and deleted the last part For Each wb In xlApp...
I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub
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
Hundreds of xlsx files in a directory are imported into a MS Access 2010 Database.
I've to clean the worksheet before importing.
Question is: How to delete all rows that have no data in column A and all columns starting from the O to XFD?
The code below works but for one file a time.
All red must be deleted.
Private Sub Comand_Click()
Dim FullPath As String
Dim oXL As Object, oWb As Object, oWs As Object
FullPath = "D:\Access\_Test_XlsImport\FileName.xlsx"
Set oXL = CreateObject("Excel.Application")
Set oWb = oXL.Workbooks.Open(FullPath)
Set oWs = oWb.Sheets("Worksheet_name")
oXL.Visible = True
With oWs
.Columns("O:XFD").Delete
.Rows("xx:xx").Delete ' <---problem to identify the starting point to delete below..
End With
oWb.Save
CleanUp:
oWb.Close False
oXL.Quit
Set oWb = Nothing
Set oXL = Nothing
Set oWs = Nothing
End Sub
I would pull out the oXL variable and make it global to your module so you only open it once.
Then put the other Excel objects into the subroutine that cleans the worksheets
Something like this should work - substitute your folder for the constant
The DIR command just matches all files that match the xlsx file spec and processes each of them in the loop
Just a warning - there is no check for files that have NO Data in
column A - if that happens the program will continue until all rows
have been exhausted.
EDIT - Modified to remove all empty rows up until last non-empty cell
Option Compare Database
Option Explicit
' Use these as global
Private oXL As Object
Private Sub Comand_Click()
Const SEARCH_FOLDER As String = "C:\Databases\"
Const EXCEL_FILES As String = "*.xlsx"
Dim FullPath As String
Dim strExcelFolder As String
Dim strFilename As String
' Open Excel
Set oXL = CreateObject("Excel.Application")
oXL.Visible = True
strFilename = Dir(SEARCH_FOLDER & EXCEL_FILES)
While strFilename <> ""
ProcessExcelFile SEARCH_FOLDER, strFilename
strFilename = Dir()
Wend
CleanUp:
oXL.Quit
Set oXL = Nothing
End Sub
Private Sub ProcessExcelFile(strExcelFolder As String, strExcelFile As String)
Dim oWb As Object, oWs As Object
Dim strFullPath As String
Dim LastRow As Long
strFullPath = strExcelFolder & strExcelFile
Set oWb = oXL.Workbooks.Open(strFullPath)
Set oWs = oWb.Sheets(1)
With oWs
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
.Columns("O:XFD").Delete
' Select All rows in Column A up to last filled row
.Range(“A1:A" & LastRow).Select
' Delete all rows with empty cell in A - up to last filled row
oXL.Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Save
.Close False
End With
Set oWb = Nothing
Set oWs = Nothing
End Sub
I've written this script to search an Outlook folder containing a series of emails with a certain string of information in the email body to copy into an Excel file.
When I first created and ran the script there weren't any problems, this is the second time I'm running it and it's excruciatingly slow and froze up my computer. I noticed it seems to be opening a new instance of Excel for each email.
I'm confused because it ran without error the first time, no changes to the script and second time running it, well I couldn't let it finish because the computer froze. Is there any way to not open a new instance for every email?
I'm not interested in revamping the entire code, but if we can make it more efficient in a simple way, count me in.
To be clear, this is run from Outlook as a rule and is run once a week.
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim xlWB As Object
Dim xlSheet As Object
Dim xlOpenWB As Object
Dim vText As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim xlUp As Long
Dim FileName As String
xlUp = -4162
FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"
enviro = (Environ("USERPROFILE"))
'the path of the workbook VB function, don't change
strPath = enviro & FileName
'Add the workbook to input the data
Set xlWB = xlApp.Workbooks.Add()
xlWB.SaveAs (strPath)
Set xlOpenWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlOpenWB.Sheets("newhires")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'sText is content of the email
sText = olItem.Body
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.pattern = "(Employee Number\s*[:]\s*(\d*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("A" & rCount) = vText
vText.RemoveDuplicates Columns:=Array(1)
xlOpenWB.Close 1
xlApp.Quit
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlOpenWB = Nothing
End Sub
Ok, so you are running this as a rule with a script as the action. Use GetObject to get the current instance and if an error occurs create one. May also want to remove the quit call as that is exiting out of Excel.
Sub CopyToExcel(olItem As Outlook.MailItem)
On Error Resume Next
Dim xlApp as Object
Dim xlWB As Object
Dim xlSheet As Object
Dim xlOpenWB As Object
Dim vText As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim xlUp As Long
Dim FileName As String
xlUp = -4162
'try and get the current running object
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then 'no object was found so create one
Set xlApp = CreateObject("Excel.Application")
Err.Clear
End If
FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"
enviro = (Environ("USERPROFILE"))
'the path of the workbook VB function, don't change
strPath = enviro & FileName
'Add the workbook to input the data
Set xlWB = xlApp.Workbooks.Add()
xlWB.SaveAs (strPath)
Set xlOpenWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlOpenWB.Sheets("newhires")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'sText is content of the email
sText = olItem.Body
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "(Employee Number\s*[:]\s*(\d*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("A" & rCount) = vText
vText.RemoveDuplicates Columns:=Array(1)
xlOpenWB.Close 1
'removed xlApp.Quit
xlApp = Nothing
Set Reg1 = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlOpenWB = Nothing
End Sub