I am copying a table from Outlook to Excel. The code I have found online copies the table in a new Excel file.
I want to copy the table into an existing Excel file.
Here is the code I am running in Outlook.
Sub dd()
Dim item As MailItem, x%
Dim r As Object 'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object, wkb As Object
Set xlApp = CreateObject("Excel.Application")
Set wkb = xlApp.Workbooks.Add
xlApp.Visible = True
Dim wks As Object
Set wks = wkb.Sheets(1)
For Each item In Application.ActiveExplorer.Selection
Set doc = item.GetInspector.WordEditor
For x = 1 To doc.Tables.Count
Set r = doc.Tables(x)
r.Range.Copy
wks.Paste
wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
Next
Next
End Sub
The code here
Set wkb = xlApp.Workbooks.Add
is what opens the new workbook. Try replacing this line with something like
Set wkb = xlApp.Workbooks.Open("C:\PathToExcel\File.xlsx")
Related
The below code extracts data from the active PowerPoint presentation.
Sub ExportMultiplePowerPointSlidesToExcel()
'Declare our Variables
Dim ppApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTTable As PowerPoint.Table
Dim PPTPlaceHolder As PowerPoint.PlaceholderFormat
'Declare Excel Variables.
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrkSheet As Excel.Worksheet
Dim xlRange As Excel.Range
'Grab the Currrent Presentation.
Set ppApp = GetObject(, "PowerPoint.Application")
Set PPTPres = ppApp.ActivePresentation
Set PPTSlide = PPTPres.Slides(1)
'Grab the Currrent Presentation.
'Keep going if there is an error
On Error Resume Next
'Get the Active instance of Outlook if there is one
Set xlApp = GetObject(, "Excel.Application")
'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then
'Clear Error
Err.Clear
'Create a new Excel App.
Set xlApp = New Excel.Application
'Make sure it's visible.
xlApp.Visible = True
'Add a new workbook.
Set xlBook = xlApp.Workbooks.Add
'Add a new worksheet.
Set xlWrkSheet = xlBook.Worksheets.Add
End If
'Set the Workbook to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKBOOK IN THE EXCEL APP.
Set xlBook = Workbooks("Cycle 2 - FSO Dirs and EDs - CCG Talent Review template.xlsm")
'Set the Worksheet to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKSHEET IN THE WORKBOOK.
Set xlWrkSheet = xlBook.Worksheets("CCG list")
Range("B3").Value = PPTSlide.Shapes(4).TextFrame.TextRange
Range("E3").Value = PPTSlide.Shapes(7).TextFrame.TextRange
'Set the Worksheet Column Width.
xlWrkSheet.Columns.ColumnWidth = 20
'Set the Worksheet Row Height.
xlWrkSheet.Rows.RowHeight = 20
'Set the Horizontal Alignment so it's to the Left.
xlWrkSheet.Cells.HorizontalAlignment = xlLeft
'Turn off the Gridlines.
xlApp.ActiveWindow.DisplayGridlines = False
End Sub
How do I loop through the presentations in the current directory to perform the action?
I have attempted numerous methods but I can't seem to indicate each presentation. The name of the presentation should be irrelevant.
I am trying to copy Word paragraphs to Excel cells, but I am hung up on
Runtime error 9: Subscript out of range.
I have searched. Everything I read says it cannot find the file, but the file is in the same folder, and the name is not mis-spelled, and the extension is correct. So, I am stumped. The original code comes from here: How to copy a formatted paragraph from Word 2013 to Excel?.
Private Sub Load_Schedule()
Dim ParaCount As Integer
Dim wDoc As Word.Document
Dim wb As Workbook
Dim ws As Worksheet
Set wDoc = ActiveDocument
Set wb = Workbooks("new.xlsm")
Set ws = wb.Sheets("Sheet1")
ws.Activate
ws.Columns(1).AutoFit
For ParaCount = 1 To wDoc.Paragraphs.Count
wDoc.Paragraphs(ParaCount).Range.FormattedText.Copy
Sheets(ws).Cells(ParaCount, 1).PasteSpecial
Paste:=xlPasteFormats
Next ParaCount
End Sub
The error comes on this line: Set wb = Workbooks("new.xlsm")
As you work with both applications, you should use full declarations like Word.Document and Excel.Workbook (if you already referenced the appropriate libraries).
An already opened Excel file can be referenced without path.
The Paste:= ... parameter belongs to the previous code line, so you have to add a blank + undersore at the end of the previous line or put them together into one line.
Please reference your worksheet's cell by ws.Cells ... and not by Sheets(ws), as your "ws" already is a worksheet object and not a string.
The further answer depends, if you run your code from Word-VBA or from Excel-VBA.
Word VBA
If you want to reference an Excel file from Word-VBA, you need the Excel.Application object additionally.
If Excel is already started, you can use the existing application object - otherwise you create one and make it visible.
Same with your Excel file: If it's already open, you use it - if not, you open it.
Private Sub LoadSchedule()
Dim ParaCount As Integer
Dim wDoc As Word.Document
Dim objExcel As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
On Error GoTo 0
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
End If
On Error Resume Next
Set wb = objExcel.Workbooks("new.xlsm")
On Error GoTo 0
If wb Is Nothing Then
Set wb = objExcel.Workbooks.Open(objExcel.DefaultFilePath & "\new.xlsm")
' or ThisDocument.Path or whatever path
End If
Set wDoc = ActiveDocument
Set ws = wb.Sheets("Sheet1")
For ParaCount = 1 To wDoc.Paragraphs.Count
wDoc.Paragraphs(ParaCount).Range.FormattedText.Copy
ws.Cells(ParaCount, 1).PasteSpecial Paste:=xlPasteFormats
Next ParaCount
ws.Columns(1).AutoFit
'ws.Activate
End Sub
Excel VBA
In Excel you can try to reference an already opened Word file directly as ActiveDocument without getting the Word.Application additionally.
Private Sub LoadSchedule()
Dim ParaCount As Integer
Dim wDoc As Word.Document
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
On Error Resume Next
Set wb = Workbooks("new.xlsm")
On Error GoTo 0
If wb Is Nothing Then
Set wb = Workbooks.Open(Application.DefaultFilePath & "\new.xlsm")
End If
Set wDoc = ActiveDocument
Set ws = wb.Sheets("Sheet1")
For ParaCount = 1 To wDoc.Paragraphs.Count
wDoc.Paragraphs(ParaCount).Range.FormattedText.Copy
ws.Cells(ParaCount, 1).PasteSpecial Paste:=xlPasteFormats
Next ParaCount
ws.Columns(1).AutoFit
'ws.Activate
End Sub
You need to specify the full path to the excel file - you say it's the same as the word document so this will work:
Sub GetXLFileInWord()
Dim xl As Excel.Application
Set xl = New Excel.Application
Dim wb As Excel.Workbook
Set wb = xl.Documents.Open(ThisDocument.Path & "\new.xlsm")
This problem has consumed a lot of my time now. Everytime I run code from access to launch excel read file location and then open the excel on that file location, make changes and close. I see that this leaves an orphan excel process. I have tried all ways of referencing and possible solutions suggested out on internet, but nothing to help. My code as below. Any help or suggestions would be great:
Public Sub productdetailprinter()
Dim i As Double
Dim dbs As DAO.Database
Dim recSet As Recordset
Dim wb As Workbook
Dim ws As Worksheet
Dim tableName As String
Dim recTable As Recordset
Dim fld As DAO.Field
Dim k As Integer
Dim r As Integer
Dim intformat As Integer
Dim wrksht As Worksheet
Dim wrkbk As Workbook
Dim filelocation As String
Dim xl As Excel.Application
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set dbs = CurrentDb
Set recSet = dbs.OpenRecordset("tbl_formList")
Set wrkbk = xl.Workbooks.Open("<location>")
Set wrksht = wrkbk.Worksheets("databaselinks")
filelocation = wrksht.Range("C5").Value
wrkbk.Close
xl.Quit
Set wrksht = Nothing
Set wrkbk = Nothing
Set xl = Nothing
Set xl = CreateObject("Excel.Application")
xl.Visible = True
xl.Workbooks.Application.DisplayAlerts = False
xl.Workbooks.Application.AskToUpdateLinks = False
Set wb = xl.Workbooks.Open(filelocation & "\product_detail.xlsx")
Set ws = wb.Worksheets("details")
xl.Workbooks.Application.AskToUpdateLinks = True
xl.Workbooks.Application.DisplayAlerts = True
ws.Range("B3", Range("B3").End(xlDown)).Select
xl.Selection.Clear
ws.Range("C3", Range("C3").End(xlDown)).Select
xl.Selection.Clear
ws.Range("D3", Range("D3").End(xlDown)).Select
xl.Selection.Clear
i = ws.Columns("B").End(xlDown).Row
i = i + 1
Do Until recSet.EOF
'code lines
recSet.MoveNext
Loop
ws.Save
wb.Close
xl.Quit
Set xl = Nothing
Set ws = Nothing
Set wb = Nothing
recTable.Close
recSet.Close
End Sub
You must close the objects in exact reverse order:
' Also:
Dim rng As Excel.Range
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wrkbk = xl.Workbooks.Open("<location>")
Set wrksht = wrkbk.Worksheets("databaselinks")
Set rng = wrksht.Range("C5")
filelocation = rng.Value
Set rng = Nothing
Set wrksht = Nothing
wrkbk.Close
Set wrkbk = Nothing
xl.Quit
Set xl = Nothing
This is tested and works at me:
Public Sub EditWorkSheet()
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim Column As Integer
Set xls = New Excel.Application
Set wkb = xls.Workbooks.Open("c:\test\test.xlsx")
Set wks = wkb.Worksheets(1)
Set rng = wks.Range("C5")
rng.Value = 4
wkb.Close True, "c:\test\test1.xlsx"
Set rng = Nothing
Set wks = Nothing
Set wkb = Nothing
xls.Quit
Set xls = Nothing
End Sub
Thank you for proposed solutions. After spending 4 hours on this.. I realized that vba wasnt happy with the way I was referencing the ranges.
ws.Range("B3", Range("B3").End(xlDown)).Select
should be referenced as
ws.Range(ws.Range("B3"), ws.Range("B3").End(xlDown)).Select
It works like a charm.. Excel instances die and no more errors.
Hope this saves someones time out there.
Thank You
I am running a few modules of code in access and am writing data into
Excel. When I write the first time, data gets written properly. But again
when I try, the new data is written on top of the old data. What should I do to
insert a new sheet?
My existing code is
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")
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.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
I think that the following code should do what you want. It's very similar to yours, except it uses the return values from the .Add methods to get the objects you want.
Public Sub YourSub()
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
'This is a bad way of handling errors. We should'
'instead check for the file existing, having correct'
'permissions, and so on, and actually stop the process'
'if an unexpected error occurs.'
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbooks.Add()
End If
CopyToWorkbook wbexcel
EndSub
Private Sub CopyToWorkbook(objWorkbook As Excel.Workbook)
Dim newWorksheet As Excel.Worksheet
set newWorksheet = objWorkbook.Worksheets.Add()
'Copy stuff to the worksheet here'
End Sub
I need to have a vb code in ms word 2003 that copy a a specific cell in excel file and paste it in word (filed). Below is what I have done and it result in error.
Sub cmdGetNumber()
Dim XL As Object
Dim WBEx As Object
Dim ExelWS As Object
Dim appwd As Object
Dim wdApp As Word.Application
''''
'On Error GoTo OLE_ERROR
Set XL = CreateObject("Excel.Application")
Set wdApp = CreateObject("Word.Application")
'Open Excel document
Set WBEx = XL.Workbooks.Open("C:\Documents and Settings\121567\Desktop\tafket1.xls")
Set ExelWS = WBEx.Worksheets("Sheet1")
XL.Visible = True
'appwd.Visible = True
ExelWS.Range("c2").Select
'Selection.Copy
'wdApp.Selection.PasteSpecial Placement:=wdInLine, DataType:=wdPasteMetafilePicture
'wdApp.Documents.Save
Set wdApp = Nothing
Set ExelWS = Nothing
Set WBEx = Nothing
End Sub
Since this macro is in Word, you don't need to explicitly open a word instance. You can just do Documents.Add to add a new document, or Documents.Open to open an existing one.
Try this:
Sub cmdGetNumber()
Dim XL As Object
Dim WBEx As Object
Dim ExelWS As Object
Dim wdDoc As Word.Document
'On Error GoTo OLE_ERROR
Set XL = CreateObject("Excel.Application")
'Open Excel document
Set WBEx = XL.Workbooks.Open("C:\Documents and Settings\121567\Desktop\tafket1.xls")
Set ExelWS = WBEx.Worksheets("Sheet1")
'XL.Visible = True
ExelWS.Range("C2").Copy
Set wdDoc = Documents.Add
wdDoc.Activate
wdDoc.Select
Selection.Paste
WBEx.Close
XL.Quit
Set WBEx = Nothing
Set ExelWS = Nothing
Set XL = Nothing
End Sub
The above code will open your excel file, copy the cell C2, then open a new word document, and paste it there.
I see you have mentioned a (filed) in your question. Did you mean a Field or a File? If it is a Field then you may want to replace Selection.Paste with the relevant field name