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

Question

大家早上好。

我不想在这里活跃，但这是我正在做的一个项目（它需要大量搜索、复制、粘贴、尝试、编辑、重复） -

这是一个包含多个列的表格，如下所示：

第 1 列 |第 2 栏 |第 3 栏 |第四栏 | ... |结肠

第 1 行 |第 1 行 |第 1 行 |第 1 行 | ... |第 1 行

第 2 行 |第 2 行 |第 2 行 |第 2 行 | ... |第 2 行

...

第 n 行 |第 n 行 |第 n 行 |第 n 行 | ... |行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

结果是这样的

第 1 列 |第 2 栏|第 3 栏 |第 i 列

第 1 行 |第 1 行 |第 1 行 |第 1 行

第 2 行 |第 2 行 |第 2 行 |第 2 行

...

第 n 行 |第 n 行 |第 n 行 |行n

分页符

第 1 列 |第 2 栏|第 3 栏 |第 i 列

第 1 行 |第 1 行 |第 1 行 |第 1 行

第 2 行 |第 2 行 |第 2 行 |第 2 行

...

第 n 行 |第 n 行 |第 n 行 |行n

分页符

重复到 i

为什么要复制/粘贴第 3 列？我希望它跳过庞大的表格，保留第 1 列、第 2 列，然后在第 3 列之后取每一列，在每个分页符之间制作一个表格。

任何帮助或指导将不胜感激。谢谢！

更新

这是我正在运行的控件 -

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

设置 CFTables Union 为我提供了正确的地址，即 $A$1:$B$50,$D$1:$D$50

除了我打算稍后清理的剪贴板的复制粘贴错误之外，它还会将一张表粘贴到带有 C 列的单词中！

我怀疑这是罪魁祸首

WordDoc.Range(WordDoc.Content.End - 1).Paste

更新#2

*#$& 我，我手动选择范围并将它们粘贴到 word 中，它做同样的事情。

Answer 1

这里有一个代码 sn-p 可以简化你的问题

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 

像您一样，它会创建两个彼此不相邻的范围，然后尝试加入这两个范围。

如果您只使用 rangeC=range(rangeA,rangeB) 它会创建一个从 rangeA 开始到范围 B 结束的范围 ("A1:D2")

如果您使用 rangeD=union(rangeA,rangeB) 它会创建两个组合的非连续范围 ("A1:B2,D1:D2")。

那么您将不会包含 C 列。

Answer 2

完成它，它可以工作，但如果你多次运行它而不关闭它，它会有一些问题。

Sub PrinttoWord() '这个宏将烟花的 excel 表格打印到 word 文档中，目前大多数表格的格式都适用。喷泉的格式化中断

   '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