エクセルで書式をコピーする高速な方法

2つのコードがあります。まず、セルAからセルBへの標準的なコピーペーストです。

Sheets(sheet_).Cells(x, 1).Copy Destination:=Sheets("Output").Cells(startrow, 2)

を使ってもほぼ同じことができます。

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)

さて、この2つ目の方法は、クリップボードにコピーして再度貼り付ける手間が省け、非常に高速です。しかし、第1の方法のように書式を越えてコピーすることはできません。2つ目の方法では500行をコピーするのにほとんど時間がかかりませんが、1つ目の方法では約5秒の時間がかかります。また、最終的には5000セル以上になる可能性があります。

そこで質問ですが、2行目にセルの書式（主にフォントの色）を含めるように変更しても、高速性は維持できますか？

理想的には、セルの値をフォントの書式と一緒に配列/リストにコピーして、ワークシートに戻す前に、さらにソートや操作ができるようにしたいのですが。

つまり、私の理想的なソリューションは次のようなものです。

for x = 0 to 5000
array(x) = Sheets(sheet_).Cells(x, 1) 'including formatting
next

for x = 0 to 5000
Sheets("Output").Cells(x, 1)
next

RTF文字列をVBAで使用することは可能でしょうか？

*Answer**

私のオリジナルの方法と新しい方法の比較を確認するために、以下のような結果が得られました、または前と後。

新コード = 65msec

Sheets("Output").Cells(startrow, 2) = Sheets(sheet_).Cells(x, 1)
Sheets("Output").Range("B" & startrow).Font.ColorIndex = Sheets(sheet_).Range("A" & x).Font.ColorIndex 'copy font colour as well

旧コード＝1296msec

'Sheets("Output").Cells(startrow, 2).Value = Sheets(sheet_).Cells(x, 1)
'Sheets(sheet_).Cells(x, 1).Copy
'Sheets("Output").Cells(startrow, 2).PasteSpecial (xlPasteFormats)
'Application.CutCopyMode = False
DevilWAH
編集された質問 23日 12月 2011 в 9:12
プログラミング
vba copy format rtf
23日 12月 2011 в 2:27
1ビュー
ソリューション

私の場合は、できません。しかし、もしあなたのニーズに合うのであれば、ループするのではなく、一度に全範囲をコピーすることで、スピードとフォーマットを両立させることができます。

range("B2:B5002").Copy Destination:=Sheets("Output").Cells(startrow, 2)

ちなみに、Range("B2:B4, B6, B11:B18")のように、カスタムの範囲文字列を作成することもできます。

編集: コピー元が"sparse"の場合、コピー終了時にコピー先を一度にフォーマットすることはできないのでしょうか？

Patrick Honorez
編集した答え 23日 12月 2011 в 3:08
解説 (8)

書くときはそれを思い出してください。

MyArray = Range("A1:A5000")

を書いているとき、あなたは本当に

MyArray = Range("A1:A5000").Value

名前を使うこともできます。

MyArray = Names("MyWSTable").RefersToRange.Value

しかし、RangeのプロパティはValueだけではありません。 使ったことがあります。

MyArray = Range("A1:A5000").NumberFormat

疑わしいのは

MyArray = Range("A1:A5000").Font

は動作しないと思いますが、私は

MyArray = Range("A1:A5000").Font.Bold

が動作することを期待します。

どのようなフォーマットをコピーしたいのかわかりませんので、試してみてください。

ただし、大きな範囲をコピー＆ペーストする場合は、誰もが思っていたように、配列を介して行うよりも、それほど遅くならないことを付け加えておきます。

編集後記。

上記の投稿をした後、私は自分のアドバイスを試してみました。 Font.ColorとFont.Boldを配列にコピーする実験は失敗しました。

以下のステートメントのうち、2番目のステートメントはタイプミスマッチで失敗します。

  ValueArray = .Range("A1:T5000").Value
  ColourArray = .Range("A1:T5000").Font.Color

ValueArray must be of type variant. ColourArrayでvariantとlongの両方を試してみましたが、成功しませんでした。

ColourArrayに値を入れて、次のステートメントを試してみました。

  .Range("A1:T5000").Font.Color = ColourArray

範囲全体がColourArrayの最初の要素に従って色付けされ、タスクマネージャで終了させるまで、Excelはプロセッサ時間の約45%を消費してループしました。

ワークシートの切り替えには時間的なペナルティがありますが、マクロの使用時間に関する最近の質問により、配列を使った作業の方が大幅に早いという考えを皆が見直すことになりました。

あなたの要求を大まかに反映した実験をしてみました。 ワークシートTime1には、太字、イタリック、下線、下付き、縁取り、赤、緑、青、茶、黄、灰-80%と選択的にフォーマットされた20個のセルを5000行並べました。

バージョン1では、コピーを使ってワークシート "Time1"からワークシート "Time2"に7つのセルをコピーしました。

バージョン2では、値と色を配列でコピーすることで、ワークシート "Time1"からワークシート "Time2"に7つのセルをコピーしました。

バージョン3では、ワークシート"Time1"からワークシート"Time2"へ、数式と色を配列でコピーして、7セルごとにコピーしました。

バージョン1では平均12.43秒、バージョン2では平均1.47秒、バージョン3では平均1.83秒かかりました。 バージョン1では数式とすべてのフォーマットを、バージョン2では値と色を、バージョン3では数式と色をコピーしました。 バージョン1と2では、例えばボールドとイタリックを追加しても、ある程度の時間を確保することができます。 しかし、21,300個の値をコピーするのに12秒しかかからないことを考えると、わざわざそれをする価値があるかどうかはわからない。

バージョン1のコード

このコードには説明が必要なものは含まれていないと思います。 もし間違っていたら、コメントでお知らせください。

Sub SelectionCopyAndPaste()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  Do While True
    ColSrcCrnt = (NumSelect Mod 20) + 1
    RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
    If RowSrcCrnt > 5000 Then
      Exit Do
    End If
    Sheets("Time1").Cells(RowSrcCrnt, ColSrcCrnt).Copy _
                 Destination:=Sheets("Time2").Cells(RowDestCrnt, ColDestCrnt)
    If ColDestCrnt = 20 Then
      ColDestCrnt = 1
      RowDestCrnt = RowDestCrnt + 1
    Else
     ColDestCrnt = ColDestCrnt + 1
    End If
    NumSelect = NumSelect + 7
  Loop
  Debug.Print Timer - StartTime
  ' Average 12.43 secs
  Application.Calculation = xlCalculationAutomatic

End Sub

** バージョン2と3用のコードです。

ユーザー型定義は、モジュール内のサブルーチンの前に置かなければなりません。 このコードは、ソースワークシートの中で、値や数式、色を配列の次の要素にコピーします。 選択が完了すると、収集した情報をコピー先のワークシートにコピーします。 これにより、必要以上にワークシートを切り替える必要がなくなります。

Type ValueDtl
  Value As String
  Colour As Long
End Type

Sub SelectionViaArray()

  Dim ColDestCrnt As Integer
  Dim ColSrcCrnt As Integer
  Dim InxVLCrnt As Integer
  Dim InxVLCrntMax As Integer
  Dim NumSelect As Long
  Dim RowDestCrnt As Integer
  Dim RowSrcCrnt As Integer
  Dim StartTime As Single
  Dim ValueList() As ValueDtl

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  ' I have sized the array to more than I expect to require because ReDim
  ' Preserve is expensive.  However, I will resize if I fill the array.
  ' For my experiment I know exactly how many elements I need but that
  ' might not be true for you.
  ReDim ValueList(1 To 25000)

  NumSelect = 1
  ColDestCrnt = 1
  RowDestCrnt = 1
  InxVLCrntMax = 0      ' Last used element in ValueList.
  With Sheets("Time2")
    .Range("A1:T715").EntireRow.Delete
  End With
  StartTime = Timer
  With Sheets("Time1")
    Do While True
      ColSrcCrnt = (NumSelect Mod 20) + 1
      RowSrcCrnt = (NumSelect - ColSrcCrnt) / 20 + 1
      If RowSrcCrnt > 5000 Then
        Exit Do
      End If
      InxVLCrntMax = InxVLCrntMax + 1
      If InxVLCrntMax > UBound(ValueList) Then
        ' Resize array if it has been filled 
        ReDim Preserve ValueList(1 To UBound(ValueList) + 1000)
      End If
      With .Cells(RowSrcCrnt, ColSrcCrnt)
        ValueList(InxVLCrntMax).Value = .Value              ' Version 2
        ValueList(InxVLCrntMax).Value = .Formula            ' Version 3
        ValueList(InxVLCrntMax).Colour = .Font.Color
      End With
      NumSelect = NumSelect + 7
    Loop
  End With
  With Sheets("Time2")
    For InxVLCrnt = 1 To InxVLCrntMax
      With .Cells(RowDestCrnt, ColDestCrnt)
        .Value = ValueList(InxVLCrnt).Value                 ' Version 2
        .Formula = ValueList(InxVLCrnt).Value               ' Version 3
        .Font.Color = ValueList(InxVLCrnt).Colour
      End With
      If ColDestCrnt = 20 Then
        ColDestCrnt = 1
        RowDestCrnt = RowDestCrnt + 1
      Else
       ColDestCrnt = ColDestCrnt + 1
      End If
    Next
  End With
  Debug.Print Timer - StartTime
  ' Version 2 average 1.47 secs
  ' Version 3 average 1.83 secs
  Application.Calculation = xlCalculationAutomatic

End Sub
Tony Dallimore
編集した答え 26日 12月 2011 в 10:19
解説 (0)

行います。

Set Sheets("Output").Range("$A$1:$A$500") =  Sheets(sheet_).Range("$A$1:$A$500")

...は動作しますか？(目の前にExcelがないのでテストできません。)

解説 (3)