从一张纸复制到另一张不连续的范围

Question

VBA菜鸟在这里（和第一次海报），可能是一个很基本的问题。然而，我还没有在互联网上的任何地方找到答案（或者我在参考书中找到答案），所以我非常难过。

如何在一张纸上取出一堆间隔排列的纸张并将它们填入另一张纸中，但没有间隙？

例如，我想标记为X的细胞从这样的纸上复印：

x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 

要在不同的表是这样的：

x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 

设计约束：

• 源范围是不连贯的列。目的地是连续的块
  • 例如来源“A3：B440，G3：G440，I3：I440”→目的地“A3：D440”
• 只有值。目标具有需要保留的条件格式
• 目标是ListObject的DataBodyRange的一部分
• 源范围列是任意的。它们通过标题索引功能找到。
• 行数是任意的，但对源和目标都是一样的。
• 我试图复制约400行和10-15列。循环是......烦人的。

这段代码可以完成工作，但它会来回反应太多，并且时间太长。我觉得这是错误的做法。

For Each hdrfield In ExportFields 

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield) 

    s_RawData.Activate 
    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy (s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i))) 
    s_Console.Activate 
    s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)).Select 
    s_Console.Paste 

    i = i + 1 

Next hdrfield 

这种方法也适用。速度更快，而且可靠。这就是我一直在做的事情，但是对源头职位进行硬编码已经不再适用了。

'transfer just the important columns from the raw data sheet to the report line sheet 
s_Console.Range("A3:A" & upperlimit).Value = s_RawData.Range("A3:A" & upperlimit).Value 'timestamp 
s_Console.Range("B3:B" & upperlimit).Value = s_RawData.Range("I3:I" & upperlimit).Value 'H2.ppm 
s_Console.Range("C3:C" & upperlimit).Value = s_RawData.Range("J3:J" & upperlimit).Value 'H2_DG.ppm 
s_Console.Range("D3:D" & upperlimit).Value = s_RawData.Range("K3:K" & upperlimit).Value 'OilTemp or GasTemp 
s_Console.Range("E3:E" & upperlimit).Value = s_RawData.Range("L3:L" & upperlimit).Value 'H2_G.ppm 
s_Console.Range("F3:F" & upperlimit).Value = s_RawData.Range("q3:q" & upperlimit).Value 'H2_mt 
s_Console.Range("G3:G" & upperlimit).Value = s_RawData.Range("r3:r" & upperlimit).Value 'H2_oo 
s_Console.Range("H3:H" & upperlimit).Value = s_RawData.Range("s3:s" & upperlimit).Value 'H2_lg 
s_Console.Range("I3:I" & upperlimit).Value = s_RawData.Range("t3:t" & upperlimit).Value 'R1 
s_Console.Range("J3:J" & upperlimit).Value = s_RawData.Range("u3:u" & upperlimit).Value 'R2 
s_Console.Range("K3:K" & upperlimit).Value = s_RawData.Range("ab3:ab" & upperlimit).Value 't1 
s_Console.Range("L3:L" & upperlimit).Value = s_RawData.Range("ac3:ac" & upperlimit).Value 't2 
s_Console.Range("M3:M" & upperlimit).Value = s_RawData.Range("ah3:Ah" & upperlimit).Value 'Cycle Type 

为什么我不能只是混合两种？为什么这个代码不工作？

s_console.range("A3:M" & lastrow).value = s_rawdata.exportrange 

（我已经有了一个自定义的“exportrange”属性写的，它可以选择复制+我想的范围内......但因为它是不连续的，我不能把它设置另一个范围的值）

感谢您的帮助！这似乎是一个基本的学习VBA，我无法找到任何有关信息。

-Matt

Answer 1

关键的一点要注意的是，你可以复制整个非连续范围了，就象这样：

Sheet1.Range("A3:B440, G3:G440, I3:I440").Copy 
Sheet2.Range("A3").PasteSpecial xlValues 

注意，在上面的Sheet1和Sheet2是codenames，但您可能会使用类似ThisWorkbook.Worksheets("mySheet")的东西。

我真的不知道你还想做什么，所以我只写了一些代码。这找到列使用查找和FindNext复制，在第2行搜索列“复制”：

Sub CopyDiscontiguousColumns() 
Dim wsFrom As Excel.Worksheet 
Dim wsTo As Excel.Worksheet 
Dim RangeToCopy As Excel.Range 
Dim HeaderRange As Excel.Range 
Dim HeaderText As String 
Dim FirstFoundHeader As Excel.Range 
Dim NextFoundHeader As Excel.Range 
Dim LastRow As Long 

Set wsFrom = ThisWorkbook.Worksheets(1) 
Set wsTo = ThisWorkbook.Worksheets(2) 
'headers are in row 2 
Set HeaderRange = wsFrom.Rows(2) 
'This is the text that identifies columns to be copies 
HeaderText = "copy" 
With wsFrom 
    'look for the first instance of "copy" in the header row 
    Set FirstFoundHeader = HeaderRange.Find(HeaderText) 
    'if "copy" is found, we're off and running 
    If Not FirstFoundHeader Is Nothing Then 
     LastRow = .Cells(.Rows.Count, FirstFoundHeader.Column).End(xlUp).Row 
     Set NextFoundHeader = FirstFoundHeader 
     'start to build the range with columns to copy 
     Set RangeToCopy = .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column)) 
     'and then just keep doing the same thing in a loop until we get back to the start 
     Do 
     Set NextFoundHeader = HeaderRange.FindNext(NextFoundHeader) 
      If Not NextFoundHeader Is Nothing Then 
       Set RangeToCopy = Union(RangeToCopy, .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column))) 
      End If 
     Loop While Not NextFoundHeader Is Nothing And NextFoundHeader.Address <> FirstFoundHeader.Address 
    End If 
End With 
RangeToCopy.Copy 
Sheet2.Range("A3").PasteSpecial xlValues 
End Sub 

Answer 2

你可以采取Application.Union功能的优势：

Sub macro1() 

Dim rngUnion As Range 

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
End With 

With s_RawData 
    Set rngUnion = Application.Union(.Range("A3:B" & upperlimit), .Range("G3:G" & upperlimit), .Range("I3:I" & upperlimit)) 
    rngUnion.Copy Destination:=s_Console.Range("A1") 
End With 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
End With 


End Sub 

此外，我觉得（我没有测试过）这应该工作以及（没有所有的选择和反弹应该比原来的循环相当快）：

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
End With 

For Each hdrfield In ExportFields 

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield) 

    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy Destination:=s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)) 

    i = i + 1 

Next hdrfield 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
End With