DownAndAccrossTableSorter

G

Greg Maxey

I scrathed together the following today in response to a post in the tables group. I searched Google groups for a similiar solution and since I didn't see anything, I wanted to share it here. As alwasy constructive criticism is welcomed.

Objective is to sort a word table down and accross. Put cursor is table to be sorted and run the following.

Option Explicit
Sub DownAndAccrossTableSorter()
Dim i As Long
Dim j As Long
Dim k As Long
Dim oCell As Cell
Dim oTmpTable As Table
Dim oRng As Word.Range
i = Selection.Tables(1).Range.Cells.Count
'Insert a temporary 1 column/multi-row table at the end of the document
With ActiveDocument.Paragraphs.Last
.Range.Paragraphs.Add
.Range.Tables.Add .Range, i, 1
End With
'Define this table
Set oTmpTable = ActiveDocument.Tables(ActiveDocument.Range.Tables.Count)
'Fill oTmpTable with contents of table to be sorted
For Each oCell In Selection.Tables(1).Range.Cells
With oTmpTable
.Cell(i, 1).Range.Text = Left(oCell.Range.Text, Len(oCell.Range.Text) - 2)
End With
i = i - 1
Next
'Sort
oTmpTable.Sort
'Redefine selected table contents based on sort
With Selection.Tables(1)
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
k = k + 1
Set oRng = oTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
'Clean up.
oTmpTable.Delete
Set oRng = Nothing
Set oTmpTable = Nothing
End Sub
 
J

Jezebel

Neat.

The purist in me would prefer that the temp table be in a separate document.
There are document layouts that would get messed up if you arbitrarily
tacked a table on the end. It also makes cleaning up easier: simply discard
the temporary document.

Dim pTempDoc as Word.Document
set pTempDoc = Documents.Add(Visible:=False)
set pTempTable = pTempDoc.Tables.Add(Range:=pTempDoc.Content, _
NumRows:=1,
_
NumColumns:=SourceTable.Range.Cells.Count)
:
pTempDoc.Close SaveChanges:=false



Since your tables have the same number of cells, a more efficient way of
copying is like this --

Dim pCell1 As Word.Cell
Dim pCell2 As Word.Cell

Set pCell1 = Table1.Cell(1, 1)
Set pCell2 = Table2.Cell(1, 1)
Do
pCell2.Range = Left$(pCell1.Range, Len(pCell1.Range) - 2)
Set pCell1 = pCell1.Next
Set pCell2 = pCell2.Next
Loop Until pCell1 Is Nothing


You could set this up as a separate function, pass the tables as arguments,
then use it for both copies.




I scrathed together the following today in response to a post in the tables
group. I searched Google groups for a similiar solution and since I didn't
see anything, I wanted to share it here. As alwasy constructive criticism
is welcomed.

Objective is to sort a word table down and accross. Put cursor is table to
be sorted and run the following.

Option Explicit
Sub DownAndAccrossTableSorter()
Dim i As Long
Dim j As Long
Dim k As Long
Dim oCell As Cell
Dim oTmpTable As Table
Dim oRng As Word.Range
i = Selection.Tables(1).Range.Cells.Count
'Insert a temporary 1 column/multi-row table at the end of the document
With ActiveDocument.Paragraphs.Last
.Range.Paragraphs.Add
.Range.Tables.Add .Range, i, 1
End With
'Define this table
Set oTmpTable = ActiveDocument.Tables(ActiveDocument.Range.Tables.Count)
'Fill oTmpTable with contents of table to be sorted
For Each oCell In Selection.Tables(1).Range.Cells
With oTmpTable
.Cell(i, 1).Range.Text = Left(oCell.Range.Text, Len(oCell.Range.Text) -
2)
End With
i = i - 1
Next
'Sort
oTmpTable.Sort
'Redefine selected table contents based on sort
With Selection.Tables(1)
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
k = k + 1
Set oRng = oTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
'Clean up.
oTmpTable.Delete
Set oRng = Nothing
Set oTmpTable = Nothing
End Sub
 
G

Greg Maxey

Jezebel,

Thanks for you comments. I like the temp document idea and have
incorporated it in the code shown below.

I played with the pCell1 and pCell2 suggestion a bit, but it want to write
to the cells left to right/top to bottom vice top to bottom/left to right.
The idea is to have the sort top to bottom/left to right.

Am I missing something?

As alwasy thanks again for sharing your suggestions.
 
G

Greg Maxey

What a dolt!!

Here is the code:

Sub DownThenAccrossTableSorter()
Dim i As Long
Dim j As Long
Dim k As Long
Dim oCell As Cell
Dim pTmpDoc As Word.Document
Dim pTmpTable As Table
Dim oRng As Word.Range
Dim SourceTable As Table
Set SourceTable = Selection.Tables(1)
i = SourceTable.Range.Cells.Count
'Insert a temporary 1 column/multi-row table in a temporary document
Set pTmpDoc = Documents.Add(Visible:=False)
Set pTmpTable = pTmpDoc.Tables.Add(Range:=pTmpDoc.Content, _
NumRows:=i, NumColumns:=1)
'Fill oTmpTable with contents of table to be sorted
For Each oCell In SourceTable.Range.Cells
With pTmpTable
.Cell(i, 1).Range.Text = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 2)
End With
i = i - 1
Next
'Sort
pTmpTable.Sort
'Redefine source table contents based on sort
With SourceTable
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
k = k + 1
Set oRng = pTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
'Clean up.
pTmpDoc.Close SaveChanges:=False
Set oRng = Nothing
End Sub
 
G

Greg Maxey

Jezebel,

I played with your pCell suggestions some more and adapted the code to sort
by users choice "top to bottom\left to right" or left to "right\top to
bottom"

If I find more time I may add a userform to avoid the slightly ambiguous
msgboxes. Thanks for the tips:

Option Explicit
Dim pCell1 As Word.Cell
Dim pCell2 As Word.Cell
Sub TableSorter()
Dim i As Long
Dim j As Long
Dim k As Long
Dim pTmpDoc As Word.Document
Dim pTmpTable As Table
Dim oRng As Word.Range
Dim SourceTable As Table
Set SourceTable = Selection.Tables(1)
i = SourceTable.Range.Cells.Count
'Insert a temporary 1 column/multi-row table in a temporary document
Set pTmpDoc = Documents.Add(Visible:=False)
Set pTmpTable = pTmpDoc.Tables.Add(Range:=pTmpDoc.Content, _
NumRows:=i, NumColumns:=1)
'Fill oTmpTable with contents of the table to be sorted
TableFillAndRefill SourceTable, pTmpTable
'Sort
pTmpTable.Sort
'Redefine source table contents based on sort
If MsgBox("Do you want to sort left to right\top to bottom?", _
vbYesNo, "Sort Order") = vbYes Then
TableFillAndRefill pTmpTable, SourceTable
Else
If MsgBox("The table will be sorted top to bottom\left to right", _
vbOKCancel, "Sort Order") = vbOK Then
With SourceTable
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
k = k + 1
Set oRng = pTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
End If
End If
'Clean up.
pTmpDoc.Close SaveChanges:=False
Set oRng = Nothing
End Sub
Sub TableFillAndRefill(pTable1 As Table, pTable2 As Table)
Set pCell1 = pTable1.Cell(1, 1)
Set pCell2 = pTable2.Cell(1, 1)
Do
pCell2.Range = Left$(pCell1.Range, Len(pCell1.Range) - 2)
Set pCell1 = pCell1.Next
Set pCell2 = pCell2.Next
Loop Until pCell1 Is Nothing
End Sub
 
J

Jezebel

Guess the next sophistication is to allow for merged and split cells in the
source table. On that other hand, that might be the road to strabismus,
insanity, and death.
 
D

Doug Robbins - Word MVP

If the aim was to produce labels that are printed down then across rather
than across then down the sheet,

' Macro to assign numbers to data source so that it can be sorted to cause
labels to print down columns
Dim Message, Title, Default, labelrows, labelcolumns, i As Integer, j As
Integer, k As Integer
Message = "Enter the number of labels in a row" ' Set prompt.
Title = "Labels per Row" ' Set title.
Default = "3" ' Set default.
' Display message, title, and default value.
labelcolumns = InputBox(Message, Title, Default)
Message = "Enter the number of labels in a column" ' Set prompt.
Title = "Labels per column" ' Set title.
Default = "5" ' Set default.
labelrows = InputBox(Message, Title, Default)
ActiveDocument.Tables(1).Columns.Add
BeforeColumn:=ActiveDocument.Tables(1).Columns(1)
ActiveDocument.Tables(1).Rows(1).Range.Cut
k = 1
For i = 1 To ActiveDocument.Tables(1).Rows.Count - labelcolumns
For j = 1 To labelrows
ActiveDocument.Tables(1).Cell(i, 1).Range.InsertBefore k + (j - 1) *
labelcolumns
i = i + 1
Next j
k = k + 1
i = i - 1
If k Mod labelcolumns = 1 Then k = k - labelcolumns + labelcolumns *
labelrows
Next i
ActiveDocument.Tables(1).Sort FieldNumber:="Column 1"
ActiveDocument.Tables(1).Rows(1).Select
Selection.Paste
ActiveDocument.Tables(1).Columns(1).Delete

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

I scrathed together the following today in response to a post in the tables
group. I searched Google groups for a similiar solution and since I didn't
see anything, I wanted to share it here. As alwasy constructive criticism
is welcomed.

Objective is to sort a word table down and accross. Put cursor is table to
be sorted and run the following.

Option Explicit
Sub DownAndAccrossTableSorter()
Dim i As Long
Dim j As Long
Dim k As Long
Dim oCell As Cell
Dim oTmpTable As Table
Dim oRng As Word.Range
i = Selection.Tables(1).Range.Cells.Count
'Insert a temporary 1 column/multi-row table at the end of the document
With ActiveDocument.Paragraphs.Last
.Range.Paragraphs.Add
.Range.Tables.Add .Range, i, 1
End With
'Define this table
Set oTmpTable = ActiveDocument.Tables(ActiveDocument.Range.Tables.Count)
'Fill oTmpTable with contents of table to be sorted
For Each oCell In Selection.Tables(1).Range.Cells
With oTmpTable
.Cell(i, 1).Range.Text = Left(oCell.Range.Text, Len(oCell.Range.Text) -
2)
End With
i = i - 1
Next
'Sort
oTmpTable.Sort
'Redefine selected table contents based on sort
With Selection.Tables(1)
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
k = k + 1
Set oRng = oTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
'Clean up.
oTmpTable.Delete
Set oRng = Nothing
Set oTmpTable = Nothing
End Sub
 
G

Greg Maxey

Doug,

Aim? There was no aim other than to kill a bit of that time shown slowly
ticking down on the homepage ;-)
 
D

Doug Robbins - Word MVP

Just as well. Trying to take aim while wallowing is likely to not produce
the desired results.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 
J

Jezebel

On the contrary. If you don't know where you're going, any path will get you
there.
 
G

Greg Maxey

Jezebel,

Yep a simple Userform with two option buttons and a command button
eliminated the message boxes. I will just file this away now as another
seldom, if ever, used little gizmo. Thanks for the tips.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0
Remove Identical words 0
VBA Export to PDF 0
Word macro that can call cells out of Excel for a find and replace 0
Extract name, address and ph# 8
VBA Coding Help for Beginner 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Extract Text in braquet and list of terms from 2 Docs 3

Top