Transfer results from Excel to Word
I have an excel workbook that passes details of members to a word document. The current code all works fine and passes the names to a series of columns in a table within a word document. Each member has four pieces of information passed across - membership number, title, first name and last name - so taking up 4 columns. The table has 9 columns so each row has two members details with the central column left blank. The information is passed a row at a time in alphabetical order. The code used is below.
What I am trying to achieve is to change it so the member details are pasted down a page (using columns 1-2-3-4) and then at the foot of the first page it starts at the top of that same page leaving column 5 blank and pasting the next name alphabetically down the page (using columns 6-7-8-9). Once that A4 page is full it starts on the next page.
Any help adjusting the code would be hugely appreciated.
Code:
ub XLWordCurrentMembers()
'xl transfer to different sheet and then different sheet to Word table
Dim WrdApp As Object, FileStr As String, Arr2() As Variant, RowCnt As Integer
Dim WrdDoc As Object, TblCell As Variant, Temp As Double, Cnt4 As Integer
Dim Lastrow As Integer, Cnt As Integer, Cnt2 As Integer, CntA As Integer, Cnt3 As Integer
Dim ARR() As Variant, Lastrow2 As Integer, LastCol As Integer, rng As Range
' clear old sheet
Sheets("CurrentMembers").Rows("1:" & Sheets("CurrentMembers").Rows.Count).ClearContents
'set #rows & #columns for transfer
With Sheets("Membership")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'load transfer rows as ranges to array(1)
ReDim ARR(Lastrow)
With Sheets("Membership") '
For Cnt = 1 To Lastrow
If .Cells(Cnt, 24).value = "renewed" Then
CntA = CntA + 1
ReDim Preserve ARR(CntA)
Set rng = .Range(.Cells(Cnt, 1), .Cells(Cnt, LastCol))
ARR(CntA - 1) = rng
End If
Next Cnt
End With
'transfer array(1) ranges to different sheet below lastrow
With Sheets("CurrentMembers")
For Cnt2 = LBound(ARR) To UBound(ARR) - 1
If .Range("B" & 1).value = vbNullString Then
Lastrow2 = 0
Else
Lastrow2 = .Range("B" & .Rows.Count).End(xlUp).Row
End If
.Range(.Cells(Lastrow2 + 1, "B"), .Cells(Lastrow2 + 1, LastCol + 1)) = ARR(Cnt2)
Next Cnt2
End With
'load 4 columns of different sheet to array(2) for tranfer to Word
Lastrow2 = Lastrow2 + 1
ReDim Arr2(Lastrow2, 4)
For Cnt3 = 1 To 4
For Cnt4 = 1 To Lastrow2
Arr2(Cnt4 - 1, Cnt3 - 1) = Sheets("CurrentMembers").Cells(Cnt4, Cnt3 + 1)
Next Cnt4
Next Cnt3
FileStr = "F:\FullMembershipList\\wordDoc\CurrentMembers.docx" '********** change address to suit
'determine number of Word table rows (x2 sheet ranges/rows from array(2) per table row)
Temp = WorksheetFunction.RoundUp((Lastrow2 / 2), 0)
On Error GoTo ErFix
'open existing Word doc
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
Set WrdDoc = WrdApp.Documents.Open(FileStr)
With WrdDoc
'clear doc
.Range(0, .Characters.Count).Delete
'add table and header
.tables.Add WrdApp.Selection.Range, NumRows:=Temp + 1, NumColumns:=9
.tables(1).cell(1, 1).Range = "Number"
.tables(1).cell(1, 2).Range = "Title"
.tables(1).cell(1, 3).Range = "First"
.tables(1).cell(1, 4).Range = "Last"
.tables(1).cell(1, 6).Range = "Number"
.tables(1).cell(1, 7).Range = "Title"
.tables(1).cell(1, 8).Range = "First"
.tables(1).cell(1, 9).Range = "Last"
'fill table from array(2)
For Cnt4 = 0 To Lastrow2 - 1
RowCnt = RowCnt + 1
For Cnt3 = 0 To 3
.tables(1).cell(RowCnt + 1, Cnt3 + 1).Range = Arr2(Cnt4, Cnt3)
.tables(1).cell(RowCnt + 1, Cnt3 + 6).Range = Arr2(Cnt4 + 1, Cnt3)
Next Cnt3
Cnt4 = Cnt4 + 1
Next Cnt4
End With
WrdApp.ActiveWindow.View.TableGridlines = True
'close, save, quit Word and clean up
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished sorting Data. Open the MS Word document 'CurrentMembers.docx' for list to be printed"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
