[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA コピペのループが重くて困ってます。』（朝男）
色の無いところに決まった数字を打ち込むマクロなのですが、
一応機能するのですが、とても重くて困っています。
どなたかご教授ください。よろしくお願いします。
Sub 稼働()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算
Dim i
Dim r
Dim s As Integer
r = 131
For s = 1 To 30
If Cells(58, r) = "" Then
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
Exit Sub
Else
End If
i = 59
Do While i < 91
Cells(91, r).Copy
If Cells(i, r).Interior.ColorIndex = xlNone Then
Cells(i, r).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Else
End If
i = i + 1
Loop
r = r + 1
Next
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
End Sub
＜ 使用 Excel：unknown、使用 OS：unknown ＞
予め範囲が決まっているので、 For .. Nextを使ったほうが分かりやすくなると思います。 自身で i = i + 1 などと書かなくてよいですし、その都度範囲判定しなくてよいので。
また、ポイントは、Cells(91, c).Copyの位置でしょうか。
以下のようなコードで同じ機能になりますか？十分検証していませんけれども。参考にしてみてください。
Sub 稼働()
Dim r As Long
Dim c As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算
For c = 131 To 160
If Cells(58, c) = "" Then Exit For
Cells(91, c).Copy
For r = 59 To 90
If Cells(r, c).Interior.ColorIndex = xlNone Then
Cells(r, c).PasteSpecial Paste:=xlPasteValues
End If
Next
Next
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
End Sub
（xyz） 2024/09/21(土) 07:02:06
>ポイントは、Cells(91, c).Copyの位置でしょうか。 補足すると、現在のコードでは同じものを何度もコピーしているということです。
まずは、以下の点に留意されることを推奨します。
(1)適切なインデントが必要です（これによってコードの構造がより明確に分かるようになります。）
(2)繰り返しの範囲が事前に判明しないときは Do ...Loop に依らざるを得ないことがありますが、
大抵は範囲が決まっていることが多く、For .. Nextのほうがコードが分かりやすくなります。
（xyz） 2024/09/21(土) 15:43:14
■１
提示のコードについて、インデントがついていません。
VBAはインデントの位置で結果が変わる言語ではありませんが、インデントを適切につけるとコードの全体の構造が把握しやすくなり、ご自身のデバッグ作業の効率アップに寄与すると思いますので、こだわりがなければインデントをつけることをお勧めします。
■２
上記を踏まえて、私なりにインデントをつけてみると↓のようになります。
Sub インデントをつけてみる()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算
Dim i
Dim r
Dim s As Integer
r = 131
For s = 1 To 30
If Cells(58, r) = "" Then
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
Exit Sub
Else
End If
i = 59
Do While i < 91
Cells(91, r).Copy
If Cells(i, r).Interior.ColorIndex = xlNone Then
Cells(i, r).PasteSpecial Paste:=xlPasteValues
Else
End If
i = i + 1
Loop
r = r + 1
Next
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
End Sub
■３
上記のように整理すると気になる点がいくつかありますので順番に挙げます。
■４
【s】が意味をなしていない。
結局【For〜Nextステートメント】のカウンターとしての役割しかないので、↓でも同様の効果になります。
For r = 131 to 160
■５
以下について、Else節がないのに記述されているのも気になりますが、プロシージャを抜けるんじゃなくて、ループを抜けるだけで事足りるでしょう。
If Cells(58, r) = "" Then
Application.CutCopyMode = False
Range("B10").Select
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
Exit Sub
Else
End If
■７
以下についても、同じくElse節がないのに記述されているのも気になりますが、それより条件判定よりCopyが前になっているので、貼り付け対象じゃないときもコピーする無駄動作になっています。
Cells(91, r).Copy
If Cells(i, r).Interior.ColorIndex = xlNone Then
Cells(i, r).PasteSpecial Paste:=xlPasteValues
Else
End If
（おそらく、処理時間がかかっているのはこれが原因）
■６
推奨する意図はありませんが、セルに値だけ書き込むのであれば値貼付け以外にも、Valueを直接参照するという手もあります。
この場合、コピーではないので「CutCopyMode」や「選択セル」に影響は出ません。
ただし、状況によっては「01」、「4/1」のような文字列が、「1」「4月1日」のように勝手に変換される可能性がありますので、状況に合わせて使い分けされるとよいと思います。
■７
ということを踏まえると、以下でも類似の効果が得られると思います。
（読み間違っていたらごめんなさい。）
Sub 整理()
Dim 行 As Long, 列 As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算
With ActiveSheet
.Range("B10").Select
For 列 = 131 To 160 Step 1
If Cells(58, 列) = "" Then
Exit For
Else
For 行 = 59 To 90 Step 1
If .Cells(行, 列).Interior.ColorIndex = xlNone Then
.Cells(行, 列).Value = Cells(91, 列).Value
End If
Next 行
End If
Next 列
End With
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
End Sub
（もこな２） 2024/09/21(土) 23:43:50
| ■７ | 以下についても、同じくElse節がないのに記述されているのも気になりますが、 | それより条件判定よりCopyが前になっているので、貼り付け対象じゃないときもコピーする無駄動作になっています。
条件判定との前後関係というよりも、 59行から90行目への書き込み処理ですが、転記元は91行目と固定である。 それにもかかわらず、32回のCopy処理を無駄に実行していること自体が問題と言うべきでしょうね。
------------------------------ さて、発言の本題です。 無駄は無駄であるが、こんな少ない件数の単なるコピーペイストだけで、35秒もかかるのは不思議と言う他ない。 これが腑に落ちなかったが、 どうやら「クリップボードエラー」というものが発生していて、これが悪さをしているようです。
クリップボードエラーのエラーメッセージは以下です。 | 「別のアプリケーションで使用されているため、 | コンテンツをクリップボードにコピーできませんでした。 | このブック内にコンテンツを貼り付けすることはできますが、他のアプリケーションでは使用できません。」
調べたところ、 「クリップボード アクセスの競合による Office でのコピー-貼り付け失敗」 https://officesupportjp.github.io/blog/cl0m4xkl2003deovs5ntr794w/ と言う記事があった。 どうやら、これに該当しているように思います。
| Windows 10 のクリップボード履歴機能 | Windows 10 バージョン 1807 から追加された新機能で、コピーしたデータの過去複数件の履歴を保持して | 貼り付けられるようになりました。この機能の実現のため、クリップボードにデータが格納されると、 | クリップボード履歴機能のプロセスからクリップボードにアクセスが発生します。
クリップボードオープン と クリップボードクローズを短期間に何度も繰り返す結果、上記の履歴機能のプロセスと 本来のExcelのコピーペイストとの間で競合が起き、エラーになるということのようです。
# 質問者さんから何の反応もないのは残念。調べたら、9月の6日の質問についてもこちらのコメントに何の反応もなかった。 # 質問掲示板は返事が必要ということを理解していないのかも知れない。
（xyz） 2024/09/23(月) 20:51:13
Sub 整理_改()
Dim 列 As Long
Dim bufRNG As Range, MyRNG As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual '手動計算
With ActiveSheet.Range("EA58:FD90")
For 列 = 1 To .Columns.Count
If .Cells(1, 列).Value = "" Then Exit For
Set bufRNG = Nothing
For Each MyRNG In Intersect(.Columns(列), .Columns(列).Offset(1))
If MyRNG.Interior.ColorIndex = xlNone Then
If bufRNG Is Nothing Then
Set bufRNG = MyRNG
Else
Set bufRNG = Union(bufRNG, MyRNG)
End If
End If
Next MyRNG
If Not bufRNG Is Nothing Then
.Cells(.Rows.Count + 1, 列).Copy
bufRNG.PasteSpecial Paste:=xlPasteValues
End If
Next 列
End With
Application.Calculation = xlCalculationAutomatic '自動計算
Application.ScreenUpdating = True
End Sub
※確かに、コピーするデータは91行目に固定なのだから、コピペは列ごとに１回でいいですね。
（もこな２ ） 2024/09/25(水) 19:48:41
トピ主がまだ見ているかわかりませんが追加で。
■９
すでに[[20240906065309]]のほうで述べましたが、速度を気にされるのであれば、【1度で済むことを何度もやらない】ということは鉄則です。
その観点でいえば、「■8」で示したコードは【１セルずつコピペ】するよりはマシですが、【列ごとにコピペ】するので最大で30回のコピペをすることになります。
このことについて、[[20240906065309]]のほうで提案があったように【配列】を利用することでコピペ（というかセル範囲への書き込み）を１度で済ますということも可能だと思いますので参考に提示します。
Sub 配列を利用()
Dim 二次元配列 As Variant
Dim x As Long, y As Long
With ActiveSheet.Range("EA58:FD91")
二次元配列 = .Value
For y = 1 To UBound(二次元配列, 2) - 1 Step 1
If 二次元配列(1, y) = "" Then
Exit For
End If
For x = 2 To UBound(二次元配列, 1) Step 1
If .Cells(x, y).Interior.ColorIndex = xlNone Then
二次元配列(x, y) = 二次元配列(UBound(二次元配列, 1), y)
End If
Next x
Next y
'▼セルへの書き込みは↓の1回のみ
.Value = 二次元配列
End With
End Sub
ただ、配列を利用する方法ですと、結局Valueプロパティを参照していることになるので「■６」のような弊害が起こる可能性もありますし、コードを理解する（読み解く）には配列を理解していることが前提になるので、難易度が２段階ほどアップしてしまうように思います。
したがって、列ごとにコピペする程度であれば許容できるということであれば、当面はそちらで対応しておき、おいおい配列を学習されてから改修に着手されるとよいと思います。
（もこな２） 2024/09/25(水) 23:24:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.