Paste cell by cell into word from excel - loop help please!

[thistlegrave]

I need some help in getting this macro to repeat copying content from a cell in excel over to word multiple times please.

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 all of those titles into Word, as ‘captions’ (while leaving space for me to go in and actually put the figures later, putting a consistent source caption on them, etc.)

I wrote enough code to get it to work for a specified range, i.e. one cell, but I want it to loop down to the next cell and insert a new caption with that new title, and then do it over and over and over again until all 250 distinct titles are entered.

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

But now I’m stuck on how to get it to move on automatically to the next cell and run again – any tips?

Thanks so much!




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

[gmaxey]

I seems odd that you want to go out to Excel up to 250 times. Why don't you go out to Excel once and get all 250 titles in on step? The following code gets data in a column headed "Titles" from Sheet1 of a workbook and loads it into an array. You can then use the array to loop through each contained title:

Sub Demo()
Dim arrData As Variant
Dim lngIndex As Long
Dim strSQL As String
'Get data from column headed "Titles" in Sheet1
strSQL = "SELECT [Titles] FROM [Sheet1$];"
xlFillList arrData, "D:\Data Stores\Load Array from Excel.xls", "True", strSQL
For lngIndex = 0 To UBound(arrData, 2)
Debug.Print arrData(0, lngIndex)
Next lngIndex
End Sub
Public Function xlFillList(arrPassed As Variant, strWorkbook As String, _
bSuppressHeader As Boolean, strSQL As String)
Dim oConn As Object
Dim oRS As Object
Dim lngNumRecs As Long
Dim strConnection As String
'Create connection:
Set oConn = CreateObject("ADODB.Connection")
If bSuppressHeader Then
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Else
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=NO"";"
End If
oConn.Open ConnectionString:=strConnection
Set oRS = CreateObject("ADODB.Recordset")
'Read the data from the worksheet.
oRS.Open strSQL, oConn, 3, 1 '3: adOpenStatic, 1: adLockReadOnly
With oRS
'Find the last record.
.MoveLast
'Get count.
lngNumRecs = .RecordCount
'Return to the start.
.MoveFirst
End With
arrPassed = oRS.GetRows(lngNumRecs)
'Cleanup
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
If oConn.State = 1 Then oConn.Close
Set oConn = Nothing
lbl_Exit:
Exit Function
End Function