從一張紙複製到另一張不連續的範圍

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