Trouble looping through content control blocks in MS Word to then export to Excel

Hello all,

I am attempting to write a macro that will allow me to type data in MS Word using content control blocks (ccblocks) in groups of 25. I then want to extract that data and import in into Excel in the next available or empty row. I then want to move to the next 25 cc blocks in the word document, etc.

I have partial success and I can accomplish my objective but the loop is not efficient and will not allow me automatically loop through groups of 25 blocks. I have to manually type in the number of blocks I want to loop through (using For i = 1 to 25, etc.) instead of just detecting the next 25 blocks. (these will always be in groups of 25 cc blocks). I at times might have hundreds or a thousand rows filled in the excel document so manually writing each set of blocks to loop through isn't efficient.

What I currently have, I map to and open a word document from excel, this is necessary when working off my excel template.

Sub Trying_To_Loop()

Dim appWD As Object
Dim wddoc As Object
Dim i As Integer
Dim r As Integer
Dim rr As Integer


On Error Resume Next
Set appWD = GetObject(, "Word.application") 
If Err = 429 Then
Set appWD = CreateObject("Word.application") 
Err.Clear
End If

'This section I map to a preexisting location where the word doc is sitting.

Set wddoc = appWD.Documents.Add(Template:="/Users/########/Library/Group Containers/UBF8T346G9.Office/MyExcelFolder/Product ID.docx", NewTemplate:=False, DocumentType:=0)
appWD.Visible = True
wddoc.Visible = True
appWD.DisplayAlerts = True


'This portion begins where I attempt to loop. As you can see in the For i = portion, I have to write 1 to 25, 26 to 50, etc. I want it to just find the next group of 25 cc blocks.

r = 1
rr = Sheets("Sheet1").Cells(Rows.Count, r).End(xlUp).Offset(1, 0).row
For i = 1 To 25
Sheets("Sheet1").Cells(rr, r).Value = wddoc.ContentControls(i).Range.Text
r = r + 1
Next i

r = 1
rr = Sheets("Sheet1").Cells(Rows.Count, r).End(xlUp).Offset(1, 0).row
For i = 26 To 50
Sheets("Sheet1").Cells(rr, r).Value = wddoc.ContentControls(i).Range.Text
r = r + 1
Next I


    wddoc.Close SaveChanges:=wdDoNotSaveChanges
    wddoc.Quit


End Sub

Any assistance would be greatly appreciated. P.S. Im working with Office 365 on a MacBook Pro.

Thank you

/r
mascon