auto created carriage returns in cells

[Chesterdave]

Hiya,

The code below adds a row to a table and then sorts the table. The issue I have is that during this process it adds a carriage return to each row, I can get rid of the extra lines but the table will double in size briefly before they are removed. What this means is that once the table gets to a certain size it expands onto the next page shifting everything else following it, once the carriage returns are gone, it goes back to being one page and everything shifts again.

Hopefully its just my sloppy code that is the issue and someone will spot what is wrong.


Public Sub AddRow(ByRef strRef As String, strType As String)
Dim test As Boolean
Dim r As Integer
Dim s As Integer


strRef = Mid(strRef, 3, Len(strRef) - 2) 'creates the text for the first column e.g. 2a, 12a
strBMName = "BM_" & strRef & "N" & strType 'creates a bookmark name e.g. BM_2aNCr

Set oRow = ThisDocument.Tables(1).Rows.Add 'creates new row on the table
oRow.Cells(1).Range.Text = strRef 'Adds to first cell on last row (2A)
oRow.Cells(4).Range.Text = strType 'Adds to fourth cell on last row (R, M, O, Cr)
oRow.Cells(2).Range.Text = "N" 'Adds N to second cell on last row
Set oRng = oRow.Range
oRng.End = oRng.End - 2
oRng.Collapse wdCollapseEnd
ActiveDocument.Bookmarks.Add strBMName, oRng 'adds the bookmark name to the row

'add 0's to string to make all same length and for sorting
With ThisDocument.Tables(1)
For r = 2 To .Rows.Count
If Len(.Cell(r, 1).Range.Text) = 4 Then
.Cell(r, 1).Range.Text = "00" & .Cell(r, 1).Range.Text 'add 00's
ElseIf Len(.Cell(r, 1).Range.Text) = 5 Then
.Cell(r, 1).Range.Text = "0" & .Cell(r, 1).Range.Text 'add 0
End If
Next
End With

'sorts table
ThisDocument.Tables(1).Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType:=wdSortFieldNumeric

'removes 0's from string and deletes carriage returns
With ThisDocument.Tables(1)
For s = 2 To .Rows.Count
If Left(.Cell(s, 1).Range.Text, 2) = "00" Then
.Cell(s, 1).Range.Text = Right(.Cell(s, 1).Range.Text, Len(.Cell(s, 1).Range.Text) - 2) 'removes 0's
.Cell(s, 1).Range.Text = Replace(.Cell(s, 1).Range.Text, Chr(13), "") 'removes carriage returns
ElseIf Left(.Cell(s, 1).Range.Text, 1) = "0" Then
.Cell(s, 1).Range.Text = Right(.Cell(s, 1).Range.Text, Len(.Cell(s, 1).Range.Text) - 1) 'removes 0's
.Cell(s, 1).Range.Text = Replace(.Cell(s, 1).Range.Text, Chr(13), "") 'removes carriage returns
End If
Next
End With

Countcheckboxes 'calls countcheckboxes
ThisDocument.UndoClear

End Sub


17878

[Kilroy]

Chester I have tried your checklist by checking numerous boxes that have added many rows to the first page as designed and do not see any carriage returns.

[gmayor]

There are some issues in your code. First of all ensure that you have the option to require variable declaration set in the VBA editor Tools > Options. This will add Option Explicit to new modules and thus enforce variable declaration. It will thus highlight the fact that you have not declared all your variables, and is a useful debugging tool.

You have some confusion between ThisDocuiment and ActiveDocument. Essentially ThisDocument is the document with the code. ActiveDocument is the currently active document. They may be the same document but it doesn't necessarily follow. It is therefore better to identify the table specifically.

When working with cell ranges, the range includes the cell end character, which is why you are getting the unwanted space in the cell when you add the zeroes. The following will not add that space and removes the leading zeroes more effciently.


Option Explicit

Public Sub AddRow(ByRef strRef As String, strType As String)
Dim Test As Boolean
Dim r As Integer
Dim s As Integer
Dim oTable As Table
Dim strBMName As String
Dim oRow As Row
Dim oRng As Range

Set oTable = ActiveDocument.Tables(1)
strRef = Mid(strRef, 3, Len(strRef) - 2) 'creates the text for the first column e.g. 2a, 12a
strBMName = "BM_" & strRef & "N" & strType 'creates a bookmark name e.g. BM_2aNCr

Set oRow = oTable.Rows.Add 'creates new row on the table
oRow.Cells(1).Range.Text = strRef 'Adds to first cell on last row (2A)
oRow.Cells(4).Range.Text = strType 'Adds to fourth cell on last row (R, M, O, Cr)
oRow.Cells(2).Range.Text = "N" 'Adds N to second cell on last row
Set oRng = oRow.Range
oRng.End = oRng.End - 2
oRng.Collapse wdCollapseEnd
ActiveDocument.Bookmarks.Add strBMName, oRng 'adds the bookmark name to the row

'add 0's to string to make all same length and for sorting
With oTable
For r = 2 To .Rows.Count
Set oRng = .Cell(r, 1).Range
oRng.End = oRng.End - 1
If Len(oRng.Text) = 3 Then
oRng.Text = "00" & oRng.Text 'add 00's
ElseIf Len(oRng.Text) = 4 Then
oRng.Text = "0" & oRng.Text 'add 0
End If
Next
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType:=wdSortFieldNumeric
For r = 2 To .Rows.Count
Set oRng = .Cell(r, 1).Range
oRng.Collapse 1
oRng.MoveEndWhile "0"
oRng.Delete
Next r
End With
Countcheckboxes 'calls countcheckboxes
End Sub

[Chesterdave]

Hi gmayor,

Thanks for doing that, it works perfectly :hifive: