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

Copying a discontinuous range from one sheet to another

提问by Matt Merrifield

VBA rookie here (and first-time poster) with what is probably a pretty basic question. However, I haven't found an answer anywhere on the internet (or in the reference books I have) so I'm pretty stumped.

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

how can I take a bunch of spaced-out columns in one sheet and stuff them into another sheet, but without the gaps?

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

For example, I want to copy the cells marked as x's from a sheet like this:

例如，我想从这样的工作表中复制标记为 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

To a different sheet like this:

到这样的不同工作表：

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 . . . . . 

Design constraints:

设计约束：

• Source range is disjointed columns. Destination is continuous block
  • e.g. Source "A3:B440, G3:G440, I3:I440" -> destination "A3:D440"
• Only the values. Destination has conditional formatting that needs to be preserved
• Destination is part of the DataBodyRange of a ListObject
• The source range columns are arbitrary. They're found by a header indexing function.
• The row-count is arbitrary, but the same for both source and destination.
• There are about 400 rows and 10-15 columns I'm trying to copy. Loops are... annoying.

• 源范围是不相交的列。目的地是连续块
  • 例如源“A3:B440、G3:G440、I3:I440”-> 目的地“A3:D440”
• 只有价值观。目标具有需要保留的条件格式
• Destination 是 ListObject 的 DataBodyRange 的一部分
• 源范围列是任意的。它们是通过标题索引功能找到的。
• 行数是任意的，但源和目标都相同。
• 我正在尝试复制大约 400 行和 10-15 列。循环是……烦人的。

This snippets gets the job done, but it bounces things back and forth too much, and takes way too long. I feel like this is The Wrong Way To Do It.

这个片段完成了工作，但它来回反弹太多，而且花费的时间太长。我觉得这是错误的做法。

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

This approach also works. It's faster, and it's reliable. It's what I've been doing, but hard-coding the source positions isn't going to work anymore.

这种方法也有效。它更快，而且可靠。这是我一直在做的事情，但是对源位置进行硬编码将不再起作用。

'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

Why can't I just have a hybrid of the two? Why won't this code work?

为什么我不能只拥有两者的混合体？为什么这段代码不起作用？

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

(i've already got a custom "exportrange" property written, which can select + copy the range I want... but I can't set the values of another range with it because it's discontinuous)

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

Thanks for the help! This seems like a fundamental piece of learning VBA that I just can't find any information about.

谢谢您的帮助！这似乎是学习 VBA 的基本部分，但我找不到任何相关信息。

-Matt

-马特

回答by Doug Glancy

The key thing to be aware of is that you can copy the whole discontinuous range at once, like this:

要注意的关键是您可以一次复制整个不连续范围，如下所示：

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

Note that in the above Sheet1 and Sheet2 are codenames, but you'll probably use something like ThisWorkbook.Worksheets("mySheet").

请注意，在上面的 Sheet1 和 Sheet2 是代号，但您可能会使用类似ThisWorkbook.Worksheets("mySheet").

I couldn't really be sure what else you're trying to do, so I just wrote some code. This finds the columns to copy by using Find and FindNext, searching for columns with "copy" in row 2:

我真的不确定你还想做什么，所以我只是写了一些代码。这通过使用 Find 和 FindNext 找到要复制的列，在第 2 行中搜索带有“copy”的列：

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

回答by sous2817

You could take advantage of the Application.Union function:

您可以利用 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

Also I think (I haven't tested it) this should work as well (without all the selecting and bouncing around...and should be considerably faster than your original loop):

另外我认为（我还没有测试过）这也应该有效（没有所有的选择和弹跳......并且应该比原始循环快得多）：

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