あるセル範囲に一度に一定の数を乗ずるには、その一定の数が入力されたセルをコピーしてから、形式を選択して貼り付けで、値貼り付け、そして「乗算」を指定するのがもっとも効率的かと思います。
これを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ベストアンサー
- 回答日時:
余談ついでですが、、、
> 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
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
でした。
ありがとうございました。
あ、たしかにそうですね。
では、こうしてみました。
でも配列でやった方がよさそうですね。
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
No.2
- 回答日時:
> 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
- 回答日時:
こんばんは。
> わざわざセルに転記し、それをコピーする代わりに、コード内で
> 乗じる数を指定できないのでしょうか?
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)が存在しない場合も理論上はありえます。
余計なことなのですが、エラーが想定できているならこちらもトラップ
しておいた方が良いでしょう^^
この回答への補足
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
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秒でOKなのです。
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)以外に貼り付け元を指定するよい方法が思いつきません。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBAで重複した値のセルに色付けをしたい 1 2022/11/02 16:12
- Excel(エクセル) VBA 特定の列に入っているテキストをコピペ 2 2023/06/14 11:24
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
- Excel(エクセル) 並べ替え、ソートの構文がわからない。 お世話になります。VBA超初心者です。 エクセルでワークシート 2 2023/06/28 21:00
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Visual Basic(VBA) Changeイベントで複数セルへの貼り付けおよび値削除時に1個目のセルのみエラーになる 3 2022/12/21 09:07
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 2 2022/05/26 17:19
- Visual Basic(VBA) 別ブックからシートのコピー 3 2022/04/01 20:07
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
このQ&Aを見た人はこんなQ&Aも見ています
-
性格の違いは生まれた順番で決まる?長男長女・中間子・末っ子・一人っ子の性格の傾向
同じ環境で生まれ育っても、生まれ順で性格は違うものなのだろうか。家庭教育研究家の田宮由美さんに教えてもらった。
-
【初歩】エクセルでのマクロ(掛け算)の作り方
その他(Microsoft Office)
-
【VBA】コピー&複数個所のペースト繰り返し
Excel(エクセル)
-
条件付き書式のコピーについて(参照先も自動で変更したい)
Excel(エクセル)
-
-
4
【Excel VBA】先頭の「0」飛びを埋める方法
Visual Basic(VBA)
-
5
【EXCEL】【VBA】空欄は飛ばして処理する方法を教えて下さい。
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excelで数式内の文字色を一部だ...
-
【エクセル】IF関数 Aまたは...
-
Excelでのコメント表示位置
-
エクセルの一つのセルに複数の...
-
エクセルで指定したセルのどれ...
-
セルをクリック⇒そのセルに入力...
-
投資番組の専門家は どういうと...
-
エクセルのセルの枠を超えて文...
-
エクセル 足して割る
-
貼り付けで複数セルに貼り付けたい
-
(Excel)数字記入セルの数値の後...
-
対象セル内(複数)が埋まった...
-
Excel2003 の『コメント』の編...
-
【Excel】 セルの色での判断は...
-
EXCEL VBA セルに既に入...
-
エクセル オートフィルタで絞...
-
セルの高さ(行高)を求めるには?
-
複数のセルのいずれかに数字が...
-
LARGE関数 飛び飛びの範囲を指定
-
Excelで住所を2つ(町名迄と番...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセル 足して割る
-
【エクセル】IF関数 Aまたは...
-
エクセルで指定したセルのどれ...
-
Excelで数式内の文字色を一部だ...
-
Excelでのコメント表示位置
-
貼り付けで複数セルに貼り付けたい
-
対象セル内(複数)が埋まった...
-
セルをクリック⇒そのセルに入力...
-
【Excel】 セルの色での判断は...
-
エクセルの一つのセルに複数の...
-
EXCEL VBA セルに既に入...
-
エクセル “13ヶ月”を“1年1ヶ月...
-
エクセル オートフィルタで絞...
-
エクセルのセルの枠を超えて文...
-
excelのCOUNTIF関数で、『範囲=...
-
(Excel)数字記入セルの数値の後...
-
枠に収まらない文字を非表示に...
-
Excel2003 の『コメント』の編...
-
Excel 例A(1+9) のように番地の...
-
複数のセルのいずれかに数字が...
おすすめ情報