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

设计约束：

来源范围是脱节列。目的地是连续的块
- e.g。源“A3：B440，G3：G440，I3：I440” - ＆gt;目的地“A3：D440”
只有价值观。目标具有需要保留的条件格式
Destination是ListObject
源范围列是任意的。它们是通过标头索引功能找到的。
行数是任意的，但源和目标都是相同的。
我正在尝试复制大约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")之类的内容。

我真的不能确定你还想做什么，所以我只写了一些代码。这将通过使用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

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

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

2 个答案: