Question

大家早上好。

我不会在这里活跃，但这是我正在进行的项目（这是一个很多的搜索，复制，粘贴，尝试，编辑，重复） -

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

Col 1 | Col 2 | Col 3 | Col 4 | ...... | Col i

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

分页

重复到我

为什么要复制/粘贴第3列？我希望它跳过大表，保留col 1，col 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

嗯*＃$＆amp;我，我手动选择范围并将它们粘贴到单词中，它也会做同样的事情。

Answer 1

以下是一个简化问题的代码段

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的结尾（＆＃34; A1：D2＆＃34;）

如果你使用rangeD = union（rangeA，rangeB），它会创建两个组合的非连续范围（＆＃34; A1：B2，D1：D2＆＃34;）。

然后你不会包括C栏。

Answer 2

完成它，它可以工作，但是如果你在没有关闭的情况下多次运行它会有一些扭结。

Sub PrinttoWord（）＆＃39;此宏将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

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

2 个答案: