3

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”
  • 只有价值观。目的地具有需要保留的条件格式
  • Destination 是 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 的基本部分，我只是找不到任何信息。

-马特

4

2 回答 2

4

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

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

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

我真的不能确定你还想做什么，所以我只是写了一些代码。这通过使用 Find 和 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
于 2013-05-10T03:39:02.330 回答
1

您可以利用 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
于 2013-05-10T01:34:02.613 回答