Paste cell by cell into Word from Excel in a loop

Question

I want, in Word VBA, to repeat copying content from Excel to Word.

Goal: I have a range in an Excel workbook about 250 cells long in column C that is a list of figure titles. I want to paste those titles into Word, as ‘captions’ (while leaving space to put the figures later, putting a consistent source caption on them, etc.)

I wrote code for one cell. I want to loop down to the next cell and insert a new caption with that new title, until all 250 distinct titles are entered.

Here is the code. I have it running a function, which runs a sub to get the title from one cell.

Sub Macro123()
Selection.InsertCaption Label:="Figure", TitleAutoText:="InsertCaption2", _
Title:=".", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
Selection.TypeText Text:=TitleDrop
Selection.Style = ActiveDocument.Styles("EcoCaption")
Selection.TypeParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeParagraph
Selection.TypeText Text:="Source: Current study, based off landings data from CDFW."
Selection.Style = ActiveDocument.Styles("EcoSource")
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
End Sub
-----------
Function TitleDrop()
GetExcelTitles
Selection.PasteAndFormat (wdFormatPlainText)

End Function
-----------------

Sub GetExcelTitles()
Dim ObjXL As Object, xlWkBk
Dim strTitleName As String

On Error Resume Next
Set ObjXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
    MsgBox "No Excel Files are open (Excel is not running)"
    Exit Sub
End If
For Each xlWkBk In ObjXL.Workbooks
    If xlWkBk.Name = "130611 Figure Lists.xlsx" Then
        xlWkBk.Sheets("Figuresonly").Range("C6").Select
        xlWkBk.Sheets("Figuresonly").Range("C6").Copy
        Exit For
    End If
Next
Set ObjXL = Nothing

End Sub

dennythecoder dennythecoder · Accepted Answer · 2013-06-13T00:46:00

Try changing some of your code to be like the following and make GetExcelTitles call your Paste Sub, not the other way around.

Dim rng as Range

For Each xlWkBk In ObjXL.Workbooks
If xlWkBk.Name = "130611 Figure Lists.xlsx" Then

For each xlWkBk.Sheets("Figuresonly").Range("C1", "C250")
  rng.Select
  rng.Copy
  Call TitleDrop
Next

End If
Next

Cheers, LC

Paste cell by cell into Word from Excel in a loop

1 Answers