エクセルVBAでの「値貼り付け、乗算」について

質問

あるセル範囲に一度に一定の数を乗ずるには、その一定の数が入力されたセルをコピーしてから、形式を選択して貼り付けで、値貼り付け、そして「乗算」を指定するのがもっとも効率的かと思います。
これをVBAで行う場合、以下のようなコードになるかと思います。

Sub test05()
Dim z As Range
Set z = ActiveCell.SpecialCells(xlLastCell).Offset(1)
z.Value = 2
z.Copy
On Error GoTo line
Range("A1:H3000").SpecialCells(xlCellTypeConstants, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
On Error GoTo 0
Application.CutCopyMode = False
z.Clear
Set z = Nothing
Exit Sub
line:
MsgBox "対象内に数値がありません。"
End Sub

上記コードは正しく作動します。
質問は、「その一定の数が入力されたセルをコピーしてから」の部分を、他の方法で代用できないかということです。上記コードでは最終セルのひとつ下、SpecialCells(xlLastCell).Offset(1)を使用していますが、SpecialCells(xlLastCell).Offset(1)が存在しない場合も理論上はありえます。
わざわざセルに転記し、それをコピーする代わりに、コード内で乗じる数を指定できないのでしょうか？

回答No.3

KenKen_SP · ベストアンサー

余談ついでですが、、、

> On Error GoTo line
> .Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
> On Error GoTo 0

#1 補足欄のエラー処理について PasteSpecial で失敗した場合、セル z の
値が残ったままになってしまいます。まず、その可能性はないでしょうけど
エラーハンドラ側でもセル z を元に戻す処理を加えた方がベターです。

　# つまり、作業セル等はエラー発生時でも元に戻す処理が必要です。

ご参考までに。

お礼

あ、たしかにそうですね。
では、こうしてみました。
でも配列でやった方がよさそうですね。

Sub test07()
Dim t As Date
Dim z As Range, r As Range

t = Now()

With ActiveSheet
If Application.WorksheetFunction.CountA(.Cells) = .Cells.Count Then
MsgBox "ワークシートに空白セルが存在しない？" _
& vbCr + vbLf & "まず、ありえない・・・。" _
& vbCr + vbLf & "シートを確認してみてください。", vbCritical, " 中止します。 （￣ロ￣；）！！　"
Exit Sub
End If

Set r = Nothing
On Error Resume Next
Set r = .Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1)
On Error GoTo 0
If r Is Nothing Then
MsgBox "対象内に数値がありません。", vbCritical, " 中止します。 （￣ロ￣；）！！　"
Exit Sub
End If

Set z = .Cells.SpecialCells(xlCellTypeBlanks).Cells(1)
z.Value = 2
z.Copy

Rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
Application.CutCopyMode = False
z.ClearContents
Set z = Nothing
Set r = Nothing
End With

MsgBox Format(Now() - t, "hh時間mm分ss秒") & "を要しました。", , " （￣ー￣）v "

End Sub

補足

したのお礼の欄のコードは間違いです。

Sub test07()
Dim t As Date
Dim z As Range, r As Range

t = Now()

With ActiveSheet
If Application.WorksheetFunction.CountA(.Cells) = .Cells.Count Then
MsgBox "ワークシートに空白セルが存在しない？" _
& vbCr + vbLf & "まず、ありえない・・・。" _
& vbCr + vbLf & "シートを確認してみてください。", vbCritical, " 中止します。 （￣ロ￣；）！！　"
Exit Sub
End If

Set r = Nothing
On Error Resume Next
Set r = .Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1)
On Error GoTo 0
If r Is Nothing Then
MsgBox "対象内に数値がありません。", vbCritical, " 中止します。 （￣ロ￣；）！！　"
Exit Sub
End If

Set z = .Cells.SpecialCells(xlCellTypeBlanks).Cells(1)
z.Value = 2
z.Copy

r.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
Application.CutCopyMode = False
z.ClearContents
Set z = Nothing
Set r = Nothing
End With

MsgBox Format(Now() - t, "hh時間mm分ss秒") & "を要しました。", , " （￣ー￣）v "

End Sub

でした。
ありがとうございました。

回答No.2

KenKen_SP

> SpecialCells(xlLastCell).Offset(1)のかわりに空白セルにいれるように
> してみました。
> これで問題はないですよね？

そうですね^^ 実質的に問題ないでしょう。

付け加えるなら、新規のテンポラリーブックを追加し、そこにデータを
書き込んでコピー。処理後閉じてしまうのはどうですか？
多少ブック追加で時間はかかるでしょうがほんの数ミリ秒だし、何より
空きセルの問題を考えずに済みます。

ところで......

> 範囲を"A1:Z10000"でやってみたところ、For Each をつかったtest03は
> 1分2秒を要しました。

配列を使った方法がありますよ。配列をループ処理した場合、セルをループ
処理した場合の各ベンチマークテストのコードを挙げておきますので、参考
になれば。

　# できるだけ正確になるように画面描写は停止したままにしてます

' // ベンチマークテストに使うAPI（ミリ秒まで計測する）
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub 配列をループ()

　　Dim vBuf　As Variant
　　Dim rSrc　As Range
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim t　　 As Long

　　Set rSrc = Range("A1:Z10000")
　　' // テストデータ配置
　　With rSrc
　　　　.Formula = "=ROW()*COLUMN()"
　　　　.Value = .Value
　　End With
　　MsgBox "[OK] でテストを開始"

　　' // テスト開始

　　t = timeGetTime()

　　Application.ScreenUpdating = False
　　vBuf = rSrc.Value
　　For i = 1 To UBound(vBuf)
　　For j = 1 To UBound(vBuf, 2)
　　　　If VarType(vBuf(i, j)) = vbDouble Then
　　　　　　vBuf(i, j) = vBuf(i, j) * 2
　　　　End If
　　Next j
　　Next i
　　rSrc.Value = vBuf

　　t = timeGetTime - t ' // 処理開始時間計測
　　MsgBox "配列をループ処理:= " & Format$(t / 1000, "0.000") & "sec"

End Sub

Sub セルをループ()

　　Dim vBuf　As Variant
　　Dim rSrc　As Range
　　Dim r　　 As Range
　　Dim t　　 As Long

　　Set rSrc = Range("A1:Z10000")
　　' // テストデータ配置
　　With rSrc
　　　　.Formula = "=ROW()*COLUMN()"
　　　　.Value = .Value
　　End With
　　MsgBox "[OK] でテストを開始"

　　' // テスト開始

　　t = timeGetTime()

　　Application.ScreenUpdating = False
　　For Each r In rSrc
　　　　If VarType(r.Value) = vbDouble Then
　　　　　　r.Value = r.Value * 2
　　　　End If
　　Next

　　t = timeGetTime - t ' // 処理開始時間計測
　　MsgBox "セルをループ処理:= " & Format$(t / 1000, "0.000") & "sec"

End Sub

お礼

> 新規のテンポラリーブックを追加し、そこにデータを書き込んでコピー。処理後閉じてしまうのはどうですか？

なるほど！ならば、新規にシートを追加し、終了後削除でもおなじですね？

でも、配列をループさせるのはすごいですね。
こういうやり方は思いつきませんでした・・・・・。
勉強になりました。

有難うございます。

回答No.1

KenKen_SP

こんばんは。

> わざわざセルに転記し、それをコピーする代わりに、コード内で
> 乗じる数を指定できないのでしょうか？

Excel VBA らしい手法で良いと思いますが...

確証はありませんが、期待されている方法は恐らくありません。[乗算] の
ためには、貼り付け元が Range でクリップボードにコピーされている必要
があるからです。

> 他の方法で代用できないか

ベーシックに、For Each で各セルに直接数値を掛けていくのでは、ダメ
なのでしょうか。例えば、

　　Dim rNum　As Range
　　Dim r　　 As Range

　　On Error Resume Next
　　' // 1: xlNumbers
　　Set rNum = Range("A1:H3000").SpecialCells(xlCellTypeConstants, 1)
　　On Error GoTo 0

　　If Not rNum Is Nothing Then
　　　　For Each r In rNum
　　　　　　r.Value = r.Value * 2　　' // 乗算
　　　　Next
　　End If

とか。

> SpecialCells(xlLastCell).Offset(1)が存在しない場合も理論上はありえます。

余計なことなのですが、エラーが想定できているならこちらもトラップ
しておいた方が良いでしょう^^

お礼

KenKen_SPさま、いつもありがとうございます。
期待する方法は恐らくないのですね。

> For Each で各セルに直接数値を掛けていくのでは

それはもちろん実験済みです。範囲を"A1:Z10000"でやってみたところ、For Each をつかったtest03は1分2秒を要しました。

Sub test03()
Dim t As Date
Dim i As Range
t = Now()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo line
For Each i In Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1)
On Error GoTo 0
i.Value = i.Value * 2
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Now() - t, "hh時間mm分ss秒") & "を要しました。"
Exit Sub
line:
MsgBox "指定範囲内に数値がありません。"
End Sub

これに対し、test05は、同じ範囲でもわずか1秒でＯＫなのです。

Sub test05()
Dim t As Date
Dim z As Range
t = Now()
Set z = ActiveCell.SpecialCells(xlLastCell).Offset(1)
z.Value = 2
z.Copy
On Error GoTo line
Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
On Error GoTo 0
Application.CutCopyMode = False
z.Clear
Set z = Nothing
MsgBox Format(Now() - t, "hh時間mm分ss秒") & "を要しました。"
Exit Sub
line:
MsgBox "対象内に数値がありません。"
End Sub

> 余計なことなのですが、エラーが想定できているならこちらもトラップ

計算をとめるのではなく、 SpecialCells(xlLastCell).Offset(1)以外に貼り付け元を指定するよい方法が思いつきません。

補足

SpecialCells(xlLastCell).Offset(1)のかわりに空白セルにいれるようにしてみました。
これで問題はないですよね？

Sub test06()
Dim t As Date
Dim z As Range

With ActiveSheet
If Application.WorksheetFunction.CountA(.Cells) = .Cells.Count Then
MsgBox "ワークシートに空白セルが存在しない？" _
& vbCr + vbLf & "まず、ありえない・・・。" _
& vbCr + vbLf & "シートを確認してみてください。", vbCritical, " 中止します。"
Exit Sub
End If

t = Now()
Set z = .Cells.SpecialCells(xlCellTypeBlanks).Cells(1)
z.Value = 2
z.Copy

On Error GoTo line
.Range("A1:Z10000").SpecialCells(xlCellTypeConstants, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply
On Error GoTo 0
Application.CutCopyMode = False
z.ClearContents
Set z = Nothing
End With
MsgBox Format(Now() - t, "hh時間mm分ss秒") & "を要しました。"
Exit Sub
line:
MsgBox "対象内に数値がありません。"
End Sub