Transfer data from Excel to double column of information in Word

[krackers]

I have an excel sheet where I produce a simple report of current member names from the central database of information holding all member details (old and current members and this sheet is named "Membership"). It places the sorted data onto a second sheet named "CurrentMembers". The code used to achieve that is below:


Private Sub CommandButton5_Click()Sheets("CurrentMembers").Rows("6:" & Sheets("CurrentMembers").Rows.Count).ClearContents


a = Worksheets("Membership").Cells(Rows.Count, 1).End(xlUp).Row


For i = 1 To a


If Worksheets("Membership").Cells(i, 11).Value = "yes" Then


Worksheets("Membership").Rows(i).Copy
Worksheets("CurrentMembers").Activate
b = Worksheets("CurrentMembers").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("CurrentMembers").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Membership").Activate


End If
Next


Application.CutCopyMode = False
ThisWorkbook.Worksheets("Membership").Cells(1, 1).Select
End Sub


I then copy that information from excel into a word document using the code as below:


Sub CopyMembersToWord()


' Declare Word variables
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordTable As Word.Table


' Declare Excel variable
Dim ExcelListObj As ListObject


' Create new instance of word
Set WordApp = New Word.Application
WordApp.Visible = True
WordApp.Activate

' Create new document in the Word Application
Set WordDoc = WordApp.Documents.Add


' Create a reference to the Excel ListObject we want to copy
Set ExcelListObj = ActiveSheet.ListObjects("MemberList")
ExcelListObj.Range.Copy


' Pause excel one second to allow clipboard to take in info etc
Application.Wait Now() + #12:00:04 AM#


' Paste the Object
With WordApp.Selection
.PasteExcelTable linkedtoexcel = True, wordformatting = False, RTF = False
End With


End Sub


That places the results into an A4 word document and works fine but all in a narrow overall column of data. I'd like to reduce amount of paper used by getting two lots of data onto a single sheet of paper; ideally with results being pasted in the order of page 1 col 1 then col2 (alongside) before going to page 2 col1, col2 etc

I am struggling getting that to work can anyone help me please?

[Dave]

You seem to be copy and pasting entire rows from "Membership" to "CurrentMembers" based on
column "K" of membership being "yes". This code would be quicker and avoids using the clipboard.
As for copying and pasting the "membership" table to Word it's hard to say what you're
trying to accomplish? Does the table include all of the cells transfered? Is there more than 1 table?
Do U want to add new tables to existing stuff in the Word doc. Why not just add a table to Word
containing the number of rows & columns U need and then fill it with your data? Maybe a bit more info.
HTH. Dave

Dim Lastrow As Integer, Cnt As Integer, Cnt2 As Integer, CntA As Integer
Dim ARR() As Variant, Lastrow2 As Integer, LastCol As Integer, Rng As Range
With Sheets("Membership")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
With Sheets("Membership") '
For Cnt = 1 To Lastrow
If .Cells(Cnt, 11).Value = "yes" 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
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

[krackers]

Hi Dave and many thanks for your reply.

I think I explained slightly wrong above. The CurrentMembers sheet is, as you say, a replicate of the members sheet (i.e. all columns) but only shows those members that have renewed membership as designated by a "yes" in column K. The transfer of data to word was only for the first 4 columns which shows their membership number together with their full name (i.e. title, firstname and surname). (This list is used each month to check members arrival at a monthly meeting.) Currently it is all done manually from the central membership sheet by sorting then copying and pasting those required columns into word and I am trying to automate the process. Since there are over 600 members it takes some time each month and as we are all volunteers it becomes a problem finding someone to do regularly.

The code I had was working partly as needed but all in a single overall column (i.e. comprising "234 Mr Fred Smith") and ran into a lot of pages to accommodate all members names. As you can imagine it is better to have each column of membership numbers/names two (or even three) wide on a page to reduce paper and reduce time checking through list to mark a member off as they arrive. I guess it would be possible for the code to create a table in word on the sheet 9 columns wide with first four columns being one set of data, an empty column in the middle to separate and then the next four columns being the next set of data - if only I knew how!

Any guidance you can give would be greatly appreciated. Hope I have explained a bit better.

[Dave]

Hi Krackers. I'm not quite clear on your transfer of info from sheet to sheet. U want to
transfer the entire row from "membership" to "currentmembers" starting at column "B".
That seemed to be what your code was doing so that is what this code does. U need to create
a Word document somewhere and then change the part of the code that has the file path to
what your's is. This code generates a 9 column table and put your stuff in it. Be aware that
it clears the document and starts new every time. Give it a trial. It seems to work. Dave

Option Explicit
Sub XLWordTable4()
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
With Sheets("Membership")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
ReDim ARR(Lastrow)
With Sheets("Membership") '
For Cnt = 1 To Lastrow
If .Cells(Cnt, 11).Value = "yes" 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
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
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
'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Temp = WorksheetFunction.RoundUp((Lastrow2 / 2), 0)
On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True 'False
Set WrdDoc = WrdApp.Documents.Open(FileStr)
With WrdDoc
.Range(0, .Characters.Count).Delete
.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"
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
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub
To operate...

Call XLWordTable4

[krackers]

Hi Dave,

Thanks - that works a treat and does exactly what I was after; now I just want to work out how it does what it does! Hugely appreciated and thanks again.

If I wanted to start the data on row 2 of the sheet CurrentMembers, what line do I need to amend?

Dave/krackers

[Dave]

Change the posted code (I forgot before posting)...

WrdApp.Visible = True 'False
WrdApp.Visible = False
I'll repost with comments. U are welcome. Thanks for posting your outcome. Dave

Option Explicit
Sub XLWordTable4()
'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
'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, 11).Value = "yes" 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 = "D:\testfolder\tabletest.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"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

[krackers]

Above and beyond Dave, many thanks once again, greatly appreciated. It will also be appreciated by our charity's secretary as it will save a ton of time each month, thanks.

David/krackers

[Dave]

"If I wanted to start the data on row 2 of the sheet CurrentMembers, what line do I need to amend?" I didn't see this before? It does require a retool which would have been much easier to do had I known from the start. Is there always something in row 1 of the sheet CurrentMembers column "B"? I'm holidaying in Cuba for a week as of tomorrow. I'll take a look at a retool when I get back. Dave

[krackers]

Thanks Dave, the plan was a simple heading and "run date" in the top row but easy enough to add that in manually after the code has been run so no worries. Enjoy your holiday - that's one location I'd love to visit and never had the chance. I need to work on other regular reports now! But since those are less frequent the need less important. I am hoping I can adapt what you have prepared to achieve those further reports so again many thanks Dave and enjoy your break.

David/krackers

[Dave]

I woke up early. U must have data in "currentmembers" Row 1 ("B") before running the routine.
Have a great New Year! Mine should involve a beach, rum and a cigar. Dave

Option Explicit
Sub XLWordTable4()
'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
'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, 11).Value = "yes" 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
For Cnt4 = 2 To Lastrow2 + 1
'Arr2(Cnt4 - 1, Cnt3 - 1) = Sheets("CurrentMembers").Cells(Cnt4, Cnt3 + 1)
Arr2(Cnt4 - 2, Cnt3 - 1) = Sheets("CurrentMembers").Cells(Cnt4, Cnt3 + 1)
Next Cnt4
Next Cnt3
FileStr = "D:\testfolder\tabletest.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"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

[snb]

Are you familiar with 'autofilter' or 'advancedfilter' ?


Private Sub CommandButton5_Click()
Sheets("CurrentMembers").usedrange.offset(5).ClearContents

with sheets("Membership").Cells(1).currentregion
.autofilter 11,"yes")
.copy Sheets("CurrentMembers").cells(6,1)
.autofilter
end with
End Sub

[krackers]

I'm not familiar with autofilter nor advanced filter but I think I understand what your code is meant to be doing. I tried to use your code but get a syntax error - is there a bracket "(" missing from somewhere?

[krackers]

I woke up early. U must have data in "currentmembers" Row 1 ("B") before running the routine.
Have a great New Year! Mine should involve a beach, rum and a cigar. Dave

Thanks Dave - hope I'm not giving you sleepless nights!!

[snb]

Are you familiar with Excel ?

Please do something yourself as well and remove the redundant )

[Dave]

krackers, you are again welcome. snb thanks for your input. I have heard of filters but won't use stuff that I don't understand and may or may not work. It seems the clipboard is also required which I prefer to avoid. Have a safe and happy Holiday season. Dave

[krackers]

Are you familiar with Excel ?

Please do something yourself as well and remove the redundant )

Why the rudeness? Because I do not understand, then maybe a helping hand or an indication in the right direction would be of more help than a poke in the eye. But thanks for your original suggestion, greatly appreciated and I have been reading up on that topic so thanks for helping me increase my knowledge base.

Remember .. it's always easy when you know the answer.