3

ここの VBA 新人 (そして初めてのポスター) は、おそらくかなり基本的な質問です。しかし、インターネット (または私が持っている参考書) のどこにも答えが見つからなかったので、かなり困惑しています。

間隔を空けて配置された列を 1 つのシートにまとめて別のシートに詰め込むにはどうすればよいですか?

たとえば、次のようなシートから x としてマークされたセルをコピーしたいとします。

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

このような別のシートに：

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

2 つのハイブリッドを使用できないのはなぜですか? このコードが機能しないのはなぜですか?

 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 に「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
于 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 に答える