How Do I Perform A Transpose To A Mailmerge? - ms-access

Question

EDIT: I Have figured out what I needed and placed the new portions of code in asterisks
I am using VBA in Access 2003 and have the following question:
I have some code that does a mailmerge to create labels, and it works fine on its own. I have been asked to see if it is possible to have the labels run down the cells and then across. Right now they fill up across then run down to the next row. If it is possible, would it be best to do it before the mailmerge executes, or do I do it in the loop that I have following the mailmerge? It is very important that the "5660 EasyPeel Address Labels" formatting stays the same. I have placed my coding below.
With oDoc.MailMerge
With .Fields
.Add oApp.Selection.Range, "FullAddress"
oApp.Selection.TypeParagraph
End With
Set oAutoText = oApp.NormalTemplate.AutoTextEntries.Add("MyLabelLayout", oDoc.Content)
oDoc.Content.Delete
.MainDocumentType = wdMailingLabels
.OpenDataSource Name:=strTxtFile, ConfirmConversions:=False, AddToRecentFiles:=False
oApp.MailingLabel.CreateNewDocument Name:="5660 Easy Peel Address Labels", Address:="", Autotext:="MyLabelLayout"
.Destination = wdSendToNewDocument
.Execute
oAutoText.Delete
'Loop through and add cell padding to each table.
intTblCount = oApp.ActiveDocument.Tables.Count
Do Until intTblCount = 0
DoEvents
oApp.ActiveDocument.Tables(intTblCount).TopPadding = PixelsToPoints(5, True)
DoEvents
oApp.ActiveDocument.Tables(intTblCount).Range.Select
With Selection
.Font.Size = 9
.Font.Name = "Janson Text LT Std"
.ParagraphFormat.LineSpacing = LinesToPoints(0.8)
.ParagraphFormat.SpaceBefore = 5
.ParagraphFormat.SpaceAfter = 5
.MoveRight wdCharacter, 5
End With
***Call TransposeTable***
DoEvents
intTblCount = intTblCount - 1
Loop
End With
*** Sub TransposeTable() 'Edited Sub from the Sub Written By Helmut Weber, MVP WordVBA
Dim C As Long ' column
Dim R As Long ' row
Dim x As Long ' just a counter
Dim y As Long ' just a counter
Dim z As Long ' just a counter
'Dim d As Long ' just a counter
Dim STempo As String
Dim sArr() As String
Dim NoGoArray As Variant: NoGoArray = Array(2, 4, 7, 9, 12, 14, 17, 19, 22, 24, 27, 29, 32, 34, 37, 39, 42, 44, 47, 49)
With Selection
.Collapse
With .Tables(1)
C = .Columns.Count
R = .Rows.Count
ReDim sArr(1 To .Range.Cells.Count)
For x = 1 To UBound(sArr)
If IsInArray(x, NoGoArray) Then
GoTo LoopContinue
Else
STempo = .Range.Cells(x).Range.Text
STempo = Left(STempo, (Len(STempo) - 2))
sArr(x) = STempo
'GoTo LoopContinue
End If
LoopContinue:
Next
'--------------------------
' Transpose Table Content
'--------------------------
C = .Columns.Count
R = .Rows.Count
x = 0
For y = 1 To C
For z = 1 To R
If IsOdd(y) Then
x = x + 1
If IsInArray(x, NoGoArray) Then
x = x + 1
.Cell(z, y).Range.Text = sArr(x)
Else
.Cell(z, y).Range.Text = sArr(x)
End If
End If
Next
Next
End With
End With
Erase NoGoArray
End Sub
Public Function IsOdd(ByVal Number As Long) As Boolean
IsOdd = (Number Mod 2 = 1)
End Function
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
'DEVELOPER: Ryan Wells (wellsr.com)
'DESCRIPTION: Function to check if a value is in an array of values
'INPUT: Pass the function a value to search for and an array of values of any data type.
'OUTPUT: True if is in array, false otherwise
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
For Each element In arr
If element = valToBeFound Then
IsInArray = True
Exit Function
End If
Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function ***