I'm trying to use a loop to shorten the last part of my VBA code.
The current code I have is:
Sub InsertPics()
Dim WordApp as Object
Dim WordDoc as Object
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open("Testing.docx"
WordApp.Visible = True
Dim path() as Variant
Dim i as Long
Dim Pic as Variant
path = Application.Transpose(Sheets("Selection").Range("N10:N24").Value)
For i = LBound(ppath) To UBound(ppath)
path(i) = Sheets("Output").Range("Directory").Value & "\" & path(i) & ".jpg"
Next i
Set Pic1 = WordDoc.InlineShapes.AddPicture(path(1), False, True).ConvertToShape
Set Pic2 = WordDoc.InlineShapes.AddPicture(path(2), False, True).ConvertToShape
Set Pic3 = WordDoc.InlineShapes.AddPicture(path(3), False, True).ConvertToShape
End Sub
The Set Pic() part goes on for quite awhile so I'm looking for a way to do the same sub with a shorter code. Is there a way to loop this part?
Note: WordDoc refers to a specific word document, path() refers to a list of directory addresses that I've already defined.
You could use an array or a collection :
Sub test_volvader()
Dim i As Integer
Dim myCol As Collection
Set myCol = New Collection
For i = 1 To 3
myCol.Add WordDoc.InlineShapes.AddPicture(Path(1), False, True).ConvertToShape, i
Next i
For i = 1 To myCol.Count
YourOperationOnAPicture myCol.Item(i)
Next i
End Sub
You should put your pictures in a list too. See R3uK's collection proposal.
But if you don't need to keep a reference on your pictures, you can make it even simpler:
For i = 1 To 3
WordDoc.InlineShapes.AddPicture(path(i), False, True).ConvertToShape
Next
Related
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows and apply hidden formatting on it but it selects only the first rows of the merged cell, not the whole row.
Below is the result that I am getting.
But I am seeking a result that will hide all content in 4 columns but I am unable to find a solution for the same.
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\New folder\Episode_0_intro_UEFA_v1_EN.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("Slide Notes")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Rows.Select
WrdApp.Selection.Font.Hidden = True
WrdApp.Selection.Range.HighlightColorIndex = wdBlue
'WrdApp.Selection.Range.Next.Rows.Select
'WrdApp.Selection.Font.Hidden = True
'WrdApp.Selection.Range.HighlightColorIndex = wdBlue
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where I am doing the issue so, I can rectify it?
My Task
Split a Word document into multiple parts based on a delimiter while preserving the text format.
Where I am?
I tried a basic example with one document but without an array and it worked.
Option Explicit
Public Sub CopyWithFormat()
Dim docDestination As Word.Document
Dim docSource As Word.Document
Set docDestination = ActiveDocument
Set docSource = Documents.Add
docSource.Range.FormattedText = docDestination.Range.FormattedText
docSource.SaveAs "C:\Temp\" & "test.docx"
docSource.Close True
End Sub
Where do I stuck?
I put the whole document into an array and loop through it. Right not I get an error 424 - Object necessary on this line:
docDestination.Range.FormattedText = arrNotes(I).
I also tried these four variants without luck:
docDestination.Range.FormattedText = arrNotes(I).Range.FormattedText
docDestination.Range.FormattedText = arrNotes(I).FormattedText
docDestination.Range.FormattedText = arrNotes.Range.FormattedText(I)
docDestination.Range.FormattedText = arrNotes.FormattedText(I)
Could you please help and point me into the right direction on how to access the array properly?
My Code
Option Explicit
Sub SplitDocument(delim As String, strFilename As String)
Dim docSource As Word.Document
Dim docDestination As Word.Document
Dim I As Long
Dim X As Long
Dim Response As Integer
Dim arrNotes
Set docSource = ActiveDocument
arrNotes = Split(docSource.Range, delim)
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set docDestination = Documents.Add
docDestination.Range.FormattedText = arrNotes(I) 'throws error 424
docDestination.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "0000")
docDestination.Close True
End If
Next I
End Sub
Sub test()
'delimiter & filename
SplitDocument "###", "Articles "
End Sub
Range.FormattedText returns a range object. The Split function, on the other hand, returns an array of strings which don't include formatting. Therefore your code should find the portion of the document you wish to copy and assign that part's FormattedText to a variable declared as Range. That variable could then be inserted into another document.
Private Sub CopyRange()
Dim Src As Range, Dest As Range
Dim Arr As Range
Set Src = Selection.Range
Set Arr = Src.FormattedText
Set Dest = ActiveDocument.Range(1, 1)
Dest.FormattedText = Arr
End Sub
The above code actually works. All you would need to do is to find a way to replace the Split function in your concept with a method that identifies ranges in the source document instead of strings.
I have wrote some VBA code which I was fairly happy with. It went through a list on a worksheet, switched to another and set a variable (and thus changed some graphs) and then opened word, copied in the graphs to various bookmarks and saved the document as the variable name.
It worked like a charm and I was a happy boy (saved a good week and a bit of work for someone). I have not touched it since - or the worksheets for that matter - opened it today and it is giving me a type missmatch on the first lot. I would really love some advice as it has left me scratching my head.
Public X As Integer
Public Y As String
Sub Macro2()
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Sheets("CPD data 13-14").Select
Range("A" & LoopCounter).Select
Y = Range("A" & LoopCounter).Value
'Change the chart values
Sheets("Pretty Display (2)").Select
Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
The error hits on the following line:
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
EDIT
As suggested I have updated my code not to use select so it now reads:
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
'Change the chart values
pd.Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = pd.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
I still get the same runtime error at the same point.
try this
Option Explicit
Public X As Integer
Public Y As String
Sub Macro2()
Dim wordApp As Object
Dim LoopCounter As Integer
Dim Mystring As String
Dim ws As Worksheet, pd As Worksheet
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
' open one Word session for all the documents to be processed
Set wordApp = CreateObject("word.Application")
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
With pd
.Range("A1").Value = Y 'Change the chart values
.ChartObjects("Chart 3").Copy ' Copy the chart
End With
'act on Word application
With wordApp
'open word template
.documents.Open "LOCATION"
.Visible = True
' paste into bookmarks, "save as" document and close it
With .ActiveDocument
.Bookmarks("InstitutionName").Range = Y
.Bookmarks("Graph1").Range.PasteSpecial
Mystring = Replace(Y, " ", "")
.SaveAs Filename:="LOCATION" & Mystring & ".docx"
.Close
End With
End With
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
'Close Word
wordApp.Quit
Set wordApp = Nothing
End Sub
I couldn't have a word "Range" object directly set to an Excel "Chart" object
So I had to copy the chart and use "PasteSpecial" method of the Word "Range" object
Furthemore I worked with one Word session only, which'd result in a faster job
Finally I also made some "comsetics" to make the code more readable/maintanable
just as a suggestion: I'd always use "Option Explicit" statement. that'll force you some extra work to explicitly declare each and every variable you use, but that will also give much more control over your work and result in less debbugging issues, thus saving time at the end
My advice is to set the Explicit flag and try to decompile the code. Any variables that you didn't dimension will throw an error. This is a good time to dimension the variable and type the data appropriately.
If that doens't throw an error, which it should since you have at least one variable LoopCounter that isn't dimensioned and could therefore cause data type errors then try changing Public X As Integer to Public X As Long so as to avoid values beyond the limit of the Integer data type.
.Activate is sometimes necessary even when using .Select from my experience. Selecting a worksheet should make it the active worksheet, but that's not always the case.
I have an excel file with 160 rows and 2 columns of data - article name, price.
I also have a folder which contains photos for those articles.
The problem is that that picture names are not EXACTLY the same as the article names in my excel sheet.
For example in my sheet I have article name: "3714-012-P140" but in the folder it would be "3714-012-P140---****".
However, after the initial 3 blocks of code (3714; 012; P140 in the example) there will always show up only 1 picture in the search.
How would one go about selecting the picture with a wildcard in it?
Additionally, how would I go about locking the picture into a specific cell in excel? What I mean to say is that when I resize or delete some rows/columns, the pictures move along the cells they are assigned to.
Dim ws As Worksheet
Dim articleCode As String, _
findStr As String
Set ws = Workbooks(1).Worksheets(1)
For i = 1 to ws.UsedRange.Rows.Count
articleCode = ws.Cells(i,1)
findStr = 'some code
ActiveSheet.Pictures.Insert( _
"C:\...path...\" & findStr & ".jpg").Select
Next i
Edit: I need to insert the photo into a third column in each row of data.
Regarding "locking" a picture into a specific cell.
See here for info about how to link a shape to a cell.
Essentially you need to:
Position the picture over a cell. This can be done by setting the pictures (ie shape) .Top and .Left properties to be the same the cell you are linking the picture to.
Set the formula of the shape to equal the cell reference (this will also resize the shape to be the same size as the cell, and cause it to resize if the cell size is changed). See here
The code below taken from here will help you find a file in a folder that matches a "findstring". (It will need to be adapted!)
Sub FindPatternMatchedFiles()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objRegExp As Object
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.pattern = ".*xlsx"
objRegExp.IgnoreCase = True
Dim colFiles As Collection
Set colFiles = New Collection
RecursiveFileSearch "C:\Path\To\Your\Directory", objRegExp, colFiles, objFSO
For Each f In colFiles
Debug.Print (f)
'Insert code here to do something with the matched files
Next
'Garbage Collection
Set objFSO = Nothing
Set objRegExp = Nothing
End Sub
Have your existing code call a function that accepts the name of the article (articleCode) and returns the path of the image file:
strImage = FindImage(articleCode)
If Len(strImage) > 0 Then ActiveSheet.Pictures.Insert strImage
Then you can write your function like so:
Function FindImage(strArticle As String) As String
Dim objFile As Object
With CreateObject("Scripting.FileSystemObject")
For Each objFile In .GetFolder("c:\path\to\images").Files
If StrComp(Left$(objFile.Name, Len(strArticle)), strArticle, vbTextCompare) = 0 Then
' Found an image file that begins with the article code.
FindImage = objFile.Path
Exit Function
End If
Next
End With
End Function
The function below takes articleCode which is the name of the picture, row and column into which the picture should be input.
Function picInsert(articleCode As String, row As Integer, column As Integer)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim ws As Worksheet
Set ws = Workbooks(1).Worksheets(2) 'your worksheet where the pictures will be put
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("...path...")
i = 1
For Each objFile In objFolder.Files
If objFile.name Like (articleCode & "*") Then 'finds a picture with similar name to the one searched
With ActiveSheet.Pictures.Insert(objFile.Path)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 5
.Height = 15
End With
.Left = ActiveSheet.Cells(row, column).Left
.Top = ActiveSheet.Cells(row, column).Top
.Placement = 1 'locks the picture to a cell
End With
End If
i = i + 1
Next objFile
End Function
This is a test sub with which I tried the function above. Basically a simple loop which goes over the rows, takes the articleCode from first column and inputs a picture into third column using the function above.
Public Sub test()
Dim ws As Worksheet
Dim i As Integer
Dim articleCode As String
Set ws = Workbooks(1).Worksheets(2)
For i = 1 To ws.UsedRange.Rows.Count
articleCode = ws.Cells(i, 1)
Call picInsert(articleCode, i, 3)
Next i
End Sub
I'm trying to open two documents from excel with vba and call a word macro from this particular excel file.
The macro is working fine in Word and I also get the documents to open and the word macro to start. However when there is a switch from one document to the other the word macro goes to break-mode (which does not happen when I run it from Word instead of Excel).
I use the following code from excel:
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\Word Dummy's\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y
In word I have a sub with the parameters defined between breakets and the following code:
worddoc2 = "H:\Word Dummy's\texts.docx"
Word.Application.Activate
Documents.Open worddoc2, ReadOnly:=True
ThisDocument.Activate
Set bmks = ThisDocument.Bookmarks
Can anyone tell me why it does not run from excel and how I can fix this?
Thanks in advance.
I finally found the answer myself after a lot of searching on Google.
I needed to add :
application.EnableEvents=false
To the excel macro.
That was all. Now it works.
My complete code is huge (the macro in excel also opens two other workbooks and runs a macro in them). This part of the code is working for now (so I left it out), but I just want to add the part that it opens a worddoc and adds specific texts in it depending on what client has been chosen in the excel userform. But to show you a better idea how my code looks like, this is in excel (where the client is defined by a userform in another module):
Sub open_models (client as string)
Application.DisplayStatusBar = True
‘determine datatypes
Dim m_integer As Integer
Dim m_ultimo As String
Dim m_primo As String
Dim y As String
Dim y_integer As Integer
Dim y_old As String
Dim y_last As String
Dim wordApp As Object
Dim worddoc As String
'Determine current month and year and previous
m_integer = Format(Now, "mm")
y_integer = Format(Now, "yyyy")
If m_integer <= 9 Then
m_ultimo = "0" & m_integer - 1
m_primo = "0" & m_integer - 2
Else
m_ultimo = m_integer - 1
m_primo = m_integer - 2
End If
If m_integer = 1 Then
y = y_integer - 1
Else
y = y_integer
End If
On Error Resume Next
'open word dummy
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y, varg4:= worddoc)
On Error GoTo 0
ThisWorkbook.Activate
'reset statusbar and close this workbook
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ThisWorkbook.Close False
End Sub
And this is the code in word I am using:
Sub update_dummy(client As String, m_ultimo As String, y As String, worddoc as string)
Dim wordapp As Object
Dim rngStart As Range
Dim rngEnd As Range
Dim worddoc As String
Dim worddoc2 As String
Dim dekkingsgraad As String
Dim bmks As Bookmarks
Dim bmRange As Range
Dim rng As Range
Dim i As Boolean
On Error Resume Next
worddoc2 = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\dummytexts.docx"
'open other word
Documents.Open worddoc2, ReadOnly:=True
Documents(worddoc).Activate
Set bmks = Documents(worddoc).Bookmarks
'management summary
If client <> "PMT" Then
i = True
Set rngStart = Documents(worddoc2).Bookmarks("bn0_1_start").Range
Set rngEnd = Documents(worddoc2).Bookmarks("bn0_1_end").Range
End If
If i = True Then
Set rng = Documents(worddoc2).Range(rngStart.Start, rngEnd.End)
rng.Copy
Set bmRange = Documents(worddoc).Bookmarks("bmManagementsummary").Range
bmRange.PasteAndFormat (wdPasteDefault)
End If
i = False
On Error GoTo 0
End Sub
I have 20 more bookmarks that are defined but the code for them is all the same.
I have seen and solved this problem a few times before, the solution I found was odd.
Copy paste all your code into a text
editor, 1 for word, 1 for excel
Delete all the macros in word or excel or better yet, just create
new files.
Paste all the code into word/excel from your text editor.
I've definitely had this 3 or 4 times in Excel and Access. Especially if you previously had a breakpoint at that location.
It sounds stupid but try it and see if that works, this has saved me from insanity a few times.