Move down several rows at once (but not to last row)

Hello all,

I have a bit of code that I'd like some help with! The gist of my project is that I have a table that is several thousand rows long. It requires manual breaking at the last row of each page, so that it becomes several different tables. I have designed some code so that it selects the first cell of the last row on the page (which is indexed in the table), saves the index as an integer which is then used for calculation of rows per page (denoted SPP in my code). Currently, the code skips down a single line at a time, for a count of SPP.

The program runs fine, it just takes quite a bit of time because it moves down a row at a time. Is there any way to consolidate it so that it moves more quickly?

Code:

---

Do While i < pages   
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.SelectRow
    With Selection.Borders(wdBorderBottom)
        .LineStyle = Options.DefaultBorderLineStyle
        .LineWidth = Options.DefaultBorderLineWidth
        .Color = Options.DefaultBorderColor
    End With
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.InsertBreak Type:=wdPageBreak
    Selection.Paste
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.MoveDown Unit:=wdLine, Count:=(SPP)
    i = i + 1
Loop

---

The following adopts a different approach. As you have not defined SPP in your macro, I have substituted a fixed value for testing. It takes four to five seconds to process a 1000 row table.

Code:

---

Sub Macro1()Dim oTable As Table
Dim oRow As Row
Dim i As Integer
Const SPP As Integer = 46
    i = 1
    Do
        Set oTable = ActiveDocument.Tables(i)
        On Error GoTo err_Handler 'run out of rows
        Set oRow = oTable.Rows(SPP)
        oTable.Split BeforeRow:=oRow
        i = i + 1
    Loop
lbl_Exit:
    Set oTable = Nothing
    Set oRow = Nothing
    MsgBox "Complete"
    Exit Sub
err_Handler:
    Err.Clear
    GoTo lbl_Exit
End Sub

---

Hey Graham,

Thank you for your reply. I’ll give that a shot. I came up with a workaround to make-up for my shortcomings in VBA proficiency. I suppose I should get better at object manipulation.

This kind of works.....

Code:

---

Sub SplitTableEndOfPage()
 Dim n As Integer
 Dim k As Integer
 Dim i As Integer
 Dim tblStartPage As Long
 Dim oTable As Table
 Dim oTableRange As Range
 Dim oRow As Row
 Dim firstrow As Range
 n = ActiveDocument.Tables.Count
 k = 0
 Set firstrow = ActiveDocument.Tables(1).Rows(1).Range
 firstrow.Copy
 
 For i = 1 To n
 Set oTable = ActiveDocument.Tables(i + k)
 If (oTable.Rows.first.Range.Information(3)) <> (oTable.Rows.Last.Range.Information(3)) Then
 Set oTableRange = oTable.Range
 oTableRange.Collapse 1
 tblStartPage = oTableRange.Information(1)
 For Each oRow In oTable.Rows
 With oRow.Range
 If .Information(3) <> tblStartPage Then
 k = k + 1
 .PasteAndFormat (11)
 oTable.Rows(oRow.Index - 1).Select
 Selection.SplitTable
 tblStartPage = .Information(3)
 .InsertBefore ("Table continued from previous page.")
 End If
 End With
 Next
 End If
 Next i
 End Sub

---

Here is my two cents:

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oTbl As Table
Dim lngStart As Long, lngPageIndex as Long
Dim oRow As Row
  lngStart = 15 'or whatever value gets you close to the last row per page
  Do
    Set oTbl = ActiveDocument.Tables(ActiveDocument.Tables.Count)
    On Error Resume Next
    oTbl.Range.Paragraphs.First.Previous.Range.Font.Size = 1
    On Error GoTo 0
    On Error GoTo Err_Start
    Set oRow = oTbl.Rows(lngStart)
    lngPageIndex = oRow.Range.Information(wdActiveEndPageNumber)
    Do
      DoEvents
      Set oRow = oRow.Next
      If oRow.Range.Information(wdActiveEndPageNumber) = ActiveDocument.Paragraphs.Last.Range.Information(wdActiveEndPageNumber) Then Exit Do
    Loop Until oRow.Range.Information(wdActiveEndPageNumber) = lngPageIndex + 1
    oTbl.Split BeforeRow:=oRow
    DoEvents
  Loop
lbl_Exit:
  Exit Sub
Err_Start:
  Resume lbl_Exit
End Sub

---

This is working good for me. Kind of slow. 1000 rows 2:02

Code:

---

Sub SplitTableEndOfPage()
 Dim n As Integer
 Dim k As Integer
 Dim i As Integer
 Dim tblStartPage As Long
 Dim oTable As Table
 Dim oTableRange As Range
 Dim oRow As Row
 Dim firstrow As Range
123
 n = ActiveDocument.Tables.Count
 k = 0
 Set firstrow = ActiveDocument.Tables(1).Rows(1).Range
 firstrow.Copy
 For i = 1 To n
 Set oTable = ActiveDocument.Tables(i + k)
 If (oTable.Rows.first.Range.Information(3)) <> (oTable.Rows.Last.Range.Information(3)) Then
 Set oTableRange = oTable.Range
 oTableRange.Collapse 1
 tblStartPage = oTableRange.Information(1)
 For Each oRow In oTable.Rows
 With oRow.Range
 If .Information(3) <> tblStartPage Then
 k = k + 1
 .PasteAndFormat (11)
 oTable.Rows(oRow.Index - 1).Select
 Selection.SplitTable
 tblStartPage = .Information(3)
 .InsertBefore ("Table continued from previous page.")
 Selection.InsertBreak Type:=wdPageBreak
 .InsertBefore ("Table continued on next page.")
 End If
 End With
 Next
 End If
 Next i
 t = ActiveDocument.Tables.Count
 If t <> n Then GoTo 123 _
 Else: GoTo 321
321
 End Sub

---