Good morning everyone.
I am not to active on here but here is a project I am working on (it's a lot of search, copy, paste, try, edit, repeat) -
It's a table with Multiple columns built like this:
Col 1 | Col 2 | Col 3 | Col 4 | ... | Col i
Row 1 | Row 1 | Row 1 | Row 1 | ... | Row 1
Row 2 | Row 2 | Row 2 | Row 2 | ... | Row 2
...
Row n | Row n | Row n | Row n | ... | Row n
Sub CopySubsectionToTable()
Dim CFsh As Worksheet
Dim lastcol As Integer
Dim lastrow As Integer
Dim i As Integer
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim IDQRange As Range
Dim AnswRange As Range
Dim FWTable As Range
Set CFsh = Sheets("ConsumerFireworks")
'Finding CFsh Array's end boundaries
lastcol = CFsh.Cells(4, CFsh.Columns.Count).End(xlToLeft).Column
lastrow = CFsh.Cells(CFsh.Rows.Count, 1).End(xlUp).Row
Set IDQRange = CFsh.Range(CFsh.Cells(4, 1), CFsh.Cells(lastrow, 2))
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Destination To Word Document
Set WordApp = CreateObject(class:="Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
'Copy Tables
For i = 4 To lastcol
Set AnswRange = CFsh.Range(CFsh.Cells(4, i), CFsh.Cells(lastrow, i))
Set FWTable = Range(IDQRange, AnswRange)
FWTable.Resize(, i).Copy
If i > 4 Then WordDoc.Range(WordDoc.Content.End - 1).InsertBreak Type:=wdPageBreak
WordDoc.Range(WordDoc.Content.End - 1).Paste
WordDoc.Range.InsertParagraphAfter
'Feeble attempt to hide coppied cells
CFsh.Columns(i).Hidden = True
Next i
CFsh.Columns.Hidden = False
Application.CutCopyMode = False
Set AppWord = Nothing
End Sub
The result looks like this
Column 1 | Column 2| Column 3 | Column i
Row 1 | Row 1 | Row 1 | Row 1
Row 2 | Row 2 | Row 2 | Row 2
...
Row n | Row n | Row n | Row n
page break
Column 1 | Column 2| Column 3 | Column i
Row 1 | Row 1 | Row 1 | Row 1
Row 2 | Row 2 | Row 2 | Row 2
...
Row n | Row n | Row n | Row n
page break
repeats to i
Why is it copy/pasting column 3? I'd like it to skip through the massive table, keep the col 1, col 2, and then take every column after column 3 to make a table between each page break.
Any help or direction would be appreciated. Thanks!
Here is a control I am running -
Sub CopySubsectionToTable()
Dim CFsh As Worksheet
Dim lastcol As Integer
Dim lastrow As Integer
Dim i As Integer
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim IDQRange As Range
Dim AnswRange As Range
Dim FWTable As Range
Dim CFTables As Range
Set CFsh = Sheets("ConsumerFireworks")
'Finding CFsh Array's end boundaries
lastcol = CFsh.Cells(4, CFsh.Columns.Count).End(xlToLeft).Column
lastrow = CFsh.Cells(CFsh.Rows.Count, 1).End(xlUp).Row
Set IDQRange = CFsh.Range(CFsh.Cells(4, 1), CFsh.Cells(lastrow, 2))
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Destination To Word Document
Set WordApp = CreateObject(class:="Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
'Copy Tables
'For i = 4 To lastcol
i = 4
Set AnswRange = CFsh.Range(CFsh.Cells(4, i), CFsh.Cells(lastrow, i))
Set FWTable = Range(IDQRange, AnswRange)
Set CFTables = Union(IDQRange, AnswRange)
MsgBox ("CFTables is " & CFTables.Address)
'FWTable.Resize(, i).Copy
CFTables.Copy
If i > 4 Then WordDoc.Range(WordDoc.Content.End - 1).InsertBreak Type:=wdPageBreak
WordDoc.Range(WordDoc.Content.End - 1).Paste
'typical location for copypaste error
WordDoc.Range.InsertParagraphAfter
'Feeble attempt to hide coppied cells
CFsh.Columns(i).Hidden = True
'Next i
CFsh.Columns.Hidden = False
Application.CutCopyMode = False
Set AppWord = Nothing
End Sub
Setting the CFTables Union gives me the correct address ie $A$1:$B$50,$D$1:$D$50
Aside from the copy paste error with teh clipboard I aim to clean up later, it pastes teh one table into word with Column C!
I suspect this is the culprit
WordDoc.Range(WordDoc.Content.End - 1).Paste
Well *#$& ME, I select the ranges manually and paste them into word and it does the same thing.
Here is a code snippet which simplifies your problem
Sub Test()
Set rangeA = Range("A1:B2")
Set rangeB = Range("D1:D2")
Set rangeC = Range(rangeA, rangeB)
MsgBox ("rangeC is " & rangeC.Address)
Set rangeD = Union(rangeA, rangeB)
MsgBox ("rangeD is " & rangeD.Address)
End Sub
Like you it creates two ranges which aren't next to each other then it attempts to join the two.
If you just use rangeC=range(rangeA,rangeB) it creates a range from the start of rangeA to the end of range B ("A1:D2")
if you use rangeD=union(rangeA,rangeB) it creates a non continuous range of the two combined ("A1:B2,D1:D2").
then you won't get column C included.
Finished it, it works but has a few kinks if you run it more than once without closing out.
Sub PrinttoWord() 'this macro prints the excel table of fireworks to a word document, currently formatting works up through most of the tables. Formatting breaks at fountains
'Dim Selection As Excel.Application
Dim CFsh As Worksheet
Dim Traffic As Worksheet
Dim Template As Range
Dim lastcol As Integer
Dim lastrow As Integer
Dim lastcolT As Integer
Dim lastrowT As Integer
Dim i As Integer
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordCont As Range
Dim strFWDoc As String
Dim IDQRange As Range
Dim AnswRange As Range
Dim FWTable As Range
Dim CFTables As Range
Dim DevDef As Range
Dim Defbox As Range
Dim j As Integer
Set CFsh = Sheets("ConsumerFireworks")
Set Traffic = Sheets("Traffic")
'Finding CFsh Array's end boundaries
lastcol = CFsh.Cells(4, CFsh.Columns.Count).End(xlToLeft).Column
lastrow = CFsh.Cells(CFsh.Rows.Count, 1).End(xlUp).Row
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Tables
For i = 3 To lastcol
'i = 4 'control
CFsh.Activate
Set IDQRange = CFsh.Range(CFsh.Cells(4, 1), CFsh.Cells(lastrow, 2))
Set AnswRange = CFsh.Range(CFsh.Cells(4, i), CFsh.Cells(lastrow, i))
Set FWTable = Range(IDQRange, AnswRange)
Set CFTables = Union(IDQRange, AnswRange)
CFTables.Copy
'Finding Traffic Array's end boundaries
'MsgBox ("CFTables is " & CFTables.Address) examination
Traffic.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
lastcolT = Traffic.Cells(1, Traffic.Columns.Count).End(xlToLeft).Column
lastrowT = Traffic.Cells(Traffic.Rows.Count, 1).End(xlUp).Row
Set Template = Traffic.Range(Traffic.Cells(1, 1), Traffic.Cells(lastrowT, lastcolT))
Template.AutoFilter Field:=3, Criteria1:="<>#N/A", Operator:=xlFilterValues
'Template.Columns.AutoFit
' Merge Device Definition
Set DevDef = Traffic.Range("B1")
Set Dev = Traffic.Cells(1, 3)
Set Defbox = Traffic.Range(DevDef, Dev)
Traffic.Activate
DevDef.Select
Selection.ClearContents
Defbox.Select
Selection.Merge
With Defbox
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Columns("A:A").Select
Selection.ColumnWidth = 4.6
Columns("B:B").Select
Range("B2").Activate
Selection.ColumnWidth = 39.4
Columns("C:C").Select
'Range("C2").Activate
'Selection.ColumnWidth = 39.4
Template.Rows.AutoFit
Template.Copy
'Word not already open error
On Error Resume Next
'Activate word if it is open
Set WordApp = GetObject(class:="Word.Application")
If Err.Number = 429 Then
Err.Clear
'Create a word application if word is not open
Set WordApp = CreateObject("Word.Application")
End If
'Set word app visible
WordApp.Visible = False
'define FWDoc path
strFWDoc = Application.ActiveWorkbook.Path & "\Fireworks.docm"
'Check for document name in folder path, if not recognized, inform the user and exitmacro.
If Dir(strFWDoc) = "" Then
MsgBox "The file was not found in the folder/", cbExclamation, "Sorry, that document does not exist."
End If
'Activate Word
WordApp.Activate
'Set WordDoc = WordApp.Documents("Fireworks.docx")
Set WordDoc = WordApp.Documents(strFWDoc)
'If not open, then open
If WordDoc Is Nothing Then Set WordDoc = WordApp.Documents.Open(strFWDoc)
'activate document
WordDoc.Activate
'Paste to word
If i > 3 Then WordDoc.Range(WordDoc.Content.End - 1).InsertBreak Type:=wdPageBreak
xLApp.Activate
CFsh.Activate
Set SubSec = CFsh.Cells(2, i)
SubSec.Copy
WordApp.Activate
WordDoc.Range(WordDoc.Content.End - 1).PasteAndFormat (wdFormatOriginalText)
'WordDoc.Range(WordDoc.Content.End).Select
'Selection.Style = ActiveDocument.Styles("FW Subsection")
Application.CutCopyMode = False
'WordDoc.Range.InsertParagraphAfter
xLApp.Activate
CFsh.Activate
Set DeviceName = CFsh.Cells(3, i)
DeviceName.Copy
WordApp.Activate
WordDoc.Range(WordDoc.Content.End - 1).PasteAndFormat (wdFormatOriginalText)
'WordDoc.Range(WordDoc.Content.End).Select
'Selection.Style = ActiveDocument.Styles("FW Device Name")
Application.CutCopyMode = False
'WordDoc.Range.InsertParagraphAfter
xLApp.Activate
Template.Copy
WordApp.Activate
WordDoc.Range(WordDoc.Content.End - 1).Paste
WordDoc.Range.InsertParagraphAfter
Application.CutCopyMode = False
j = j + 1
'working method pasting and inserting page break
WordDoc.Range(WordDoc.Content.End - 1).Paste 'AndFormat (wdFormatOriginalText)
WordDoc.Tables(j).Select
WordApp.Selection.Style = ActiveDocument.Styles("No Spacing")
'Application.CutCopyMode = False
'WordDoc.Range.InsertParagraphAfter
'With WordDoc
' .Content.Style = .Styles("No Spacing")
'End With
'Feeble attempt to hide coppied cells
CFsh.Columns(i).Hidden = True
Application.CutCopyMode = False
Template.AutoFilter
Traffic.Cells.Delete
Next i
'WordDocNotFound:
'MsgBox "Microsoft Word File 'Practice.docx' is not currently open, Terminating.", 16
CFsh.Columns.Hidden = False
Application.CutCopyMode = False
WordApp.Visible = True
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.