Excel VBAmacros复制/粘贴dynamic范围的静态范围
大家，早安。
我不是在这里活跃，但这是我正在工作的一个项目（这是一个search，复制，粘贴，尝试，编辑，重复）很多 –
这是一个多列构build的表格：
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列| 专栏
第1行| 第1行| 第1行| 第1行
第2行| 第2行| 第2行| 第2行
…
行n | 行n | 行n | 第n行
分页符
第1列| 第2列| 第3列| 专栏
第1行| 第1行| 第1行| 第1行
第2行| 第2行| 第2行| 第2行
…
行n | 行n | 行n | 第n行
分页符
重复我
为什么复制/粘贴第3列？ 我希望它跳过大量的表，保留col 1，col 2，然后在第3列之后的每一列在每个分页符之间build立一个表格。
任何帮助或方向将不胜感激。 谢谢！
UPDATE
这是我正在运行的一个控制 –
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
那么*＃$＆ME，我手动select范围并将其粘贴到单词中，并执行相同的操作。
这是一个简化你的问题的代码片段
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
像你一样，它创build了两个不相邻的范围，然后试图join这两个范围。
如果您只使用rangeC = range（rangeA，rangeB），则会创build一个范围，从范围A的开始到范围B的末尾（“A1：D2”）
如果使用rangeD = union（rangeA，rangeB），则会创build两个组合的非连续范围（“A1：B2，D1：D2”）。
那么你将不会得到C列。
完成它，它的工作原理，但有几个扭结，如果你不止一次运行它没有closures。
Sub PrinttoWord（）'这个macros把fireworks的excel表格打印到一个word文档中，目前格式化通过大多数表格。 在喷泉格式化rest
'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