Excel VBA宏复制/粘贴具有动态范围的静态范围

Question

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.

Answer 1

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.

Answer 2

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