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

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

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