web-dev-qa-db-ja.com

Excelでフォーマットをコピーする高速な方法

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番目の方法ははるかに高速になり、クリップボードにコピーして再度貼り付ける必要がなくなります。ただし、最初の方法のようにフォーマット全体にコピーすることはありません。 2番目のバージョンは500行をコピーするのがほぼ瞬時であるのに対し、最初の方法は時間に約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

vBAでRTF文字列を使用することは可能ですか、それともvb.netなどでのみ可能です。

回答*

私のオリジナルのメソッドと新しいメソッドがどのように比較されるかを見るために、ここに結果があります

新しいコード= 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
vbacopyformatrtf
12
DevilWAH

私にはできません。しかし、それがあなたのニーズに合っている場合、範囲全体を一度にコピーすることにより、ループするのではなく、速度andでフォーマットすることができます：

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

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

編集：コピー元が「スパース」の場合、コピーが完了した時点でコピー先を一度にフォーマットすることはできませんか？

6
Patrick Honorez

以下のようなRange("x1").value(11)を単純に使用することもできます。

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

範囲にはデフォルトのプロパティ「Value」があり、値には3つのオプションの引数10,11,12を含めることができます。 11は、価値と形式の両方を変換するために必要なものです。クリップボードを使用しないため、高速です。-Durgesh

15
Durgesh

あなたが書くとき：

MyArray = Range("A1:A5000")

あなたは本当に書いています

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

名前を使用することもできます：

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

しかし、ValueがRangeの唯一のプロパティではありません。利用した：

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はバリアント型である必要があります。 ColourArrayのバリアントとロングの両方を試してみましたが、成功しませんでした。

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

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

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

ワークシートの切り替えには時間のペナルティがありますが、マクロの継続時間に関する最近の質問により、配列を介した作業が大幅に高速化されたという信念を誰もが確認しました。

お客様の要件を広く反映する実験を作成しました。ワークシート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
3
Tony Dallimore

Valueプロパティの後にNumberFormatプロパティを使用するだけです。この例では、範囲はColLetterおよびSheetRowと呼ばれる変数を使用して定義され、これは整数iを使用するfor-nextループから取得されますが、もちろん通常定義された範囲である可能性があります。

TransferSheet.Range（ColLetter＆SheetRow）.Value = Range（ColLetter＆i）.Value TransferSheet.Range（ColLetter＆SheetRow）.NumberFormat = Range（ColLetter＆i）.NumberFormat

0
Derek Sturdy