Below is part of a code that i am using to paste charts into ppt. It is basically picking charts from excel to update the existing ppt. I have also included inline text. where i am getting this error. Please help me identify, why this error is existing.
I am getting error at below line :-
m = shp.TextFrame.TextRange.Find(existing_date_string).Characters.Start
Sub ChangeChartData_phast()
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim sld As Slide
Dim shp As Shape
Dim wbk As Workbook
Dim wbk_copy As Workbook
Dim wbk_paste As Worksheet
Dim filepath As String
filepath = ActivePresentation.Path
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Set wbk_copy = xlApp.Workbooks.Open(filepath & "\development file.xlsm", True, False)
'xlApp.Visible = True
date_string = (wbk_copy.Worksheets("Data").Cells(13, 2))
existing_date_string = (wbk_copy.Worksheets("Data").Cells(14, 2))
wbk_copy.Close True
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
Set wbk_copy = xlApp.Workbooks.Open(filepath & "\Phast Charts Data.xlsx", True, False)
xlApp.Visible = True
Dim n As Integer
i = i + 1
For Each shp In sld.Shapes
If shp.Name = "Title1" Then
m = shp.TextFrame.TextRange.Find(existing_date_string).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (date_string)
shp.TextFrame.TextRange.Find(existing_date_string).Delete
End If
Next
Next n
xlApp.DisplayAlerts = False
wbk_copy.Close False
xlApp.DisplayAlerts = True
Maybe use Replace with a blank string or your text, instead of Delete
shp.TextFrame.TextRange.Replace FindWhat:="###", ReplaceWhat:=""
or try replace using vbNullString.
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 am trying to copy data from excel to ppt. Below is part of my code...i am getting error at the line mentioned below. The issue is that it runs most of the time but it starts throwing error suddenly. Please help me identify the reason for the same
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim sld As Slide
Dim shp As Shape
Dim wbk, wbk_copy As Workbook
Dim wbk_paste As Worksheet
Dim filepath As String
Dim date_string As String
filepath = ActivePresentation.Path
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Set wbk_copy = xlApp.Workbooks.Open(filepath & "\development file.xlsm", True, False)
'xlApp.Visible = True
date_string = (wbk_copy.Worksheets("Data").Cells(10, 2))
existing_date_string = (wbk_copy.Worksheets("Data").Cells(11, 2))
wbk_copy.Close True
Set xlApp = Nothing
For Each shp In sld.Shapes
If shp.Name = "Title1" Then
'##### Getting error on below line ####
m = shp.TextFrame.TextRange.Find(existing_date_string).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (date_string)
shp.TextFrame.TextRange.Find(existing_date_string).Delete
End If
I am trying to automatically fill in tables in a MS word file by retrieving data in various excel tables. In order to properly interact with Excel it would be very handy to work with worksheetfunction. Yet since the macro is in MS Word I am getting blocked. Any way to access it? Cheers
Dim src As Workbook
Dim ws As Worksheet
Dim t As String
Dim c As Integer
t = ThisDocument.Tables(1).Cell(1, 1).Range.Text
t = Left(t, Len(t) - 1)
Set src = workbooks.Open("https://collab.ext.../asd.xlsx", True, True)
Set ws = src.Worksheets("Data")
c = worksheetfunction.Match(t, ws.Range("A1:AA1"), False)
src.Close
Set src = Nothing
#Tim Williams thanks for your help. Corrected code below:
Dim oXL As Object
Dim oWB As Workbook
Dim oWS As Worksheet
Dim wbPath As String
Dim t As String
Dim c As Integer
Set oXL = CreateObject("Excel.Application")
oXL.Visible = False
wbPath = "https://collab.ext...asd.xlsx"
t = ThisDocument.Tables(1).Cell(1, 1).Range.Text
t = Left(t, Len(t) - 2)
Set oWB = oXL.workbooks.Open(wbPath, True, True)
Set oWS = oWB.Sheets("Data")
c = oXL.worksheetfunction.Match(t, oWS.Range("A1:AA3"), False)
oXL.ActiveWorkbook.Close SaveChanges:=False
oXL.Application.Quit
Set oXL = Nothing
Set oWB = Nothing
Set oWS = Nothing
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'm trying to fill formulas in excel sheet from access db VBA.I referred this
Here is my code
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim strFormulas(1 To 4) As Variant
txtcatpath = Form_Bom.Excelpath.Value
Set xlApp = CreateObject("Excel.Application")
With xlApp
Set wb = .Workbooks.Open(txtcatpath)
.Visible = True
End With
With wb.Sheets("common based")
strFormulas(1) = "=IF(F4<>F5,E4,E4&""&H5)"
strFormulas(2) = "=VLOOKUP(J4,F:H,3,FALSE)"
strFormulas(3) = "=IF(COUNTIF(F4:F900,F4)=1,F4,"")"
strFormulas(4) = "=SUMIF(F:F,J4,G:G)"
.Range("H4:K4").Formula = strFormulas
.Range("H4:K" & LRow & "").FillDown
End With
When debugging my code is getting broken in .Range("H4:K4").Formula = strFormulas. How do i fill the columns with the formula.