[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロの処理時間を早めたい』（こはのり）
お世話になります。
下記マクロを作りましたが約600行くらいあるシートを12シート完了するのに
10分以上かかってしまいます。
人間の手で操作するよりはましなのですが、構文を手直しすることで
処理が早くできるようであれば修正したいです。
ただ、どこをなおせばいいかと、そもそも処理が早くできるかどうかもわかりません。
お分かりになる方がいらっしゃればご助力お願いできないでしょうか。
↓マクロの説明
A1に「在庫表」と入力してあるシートを対象とし、
L列に「出荷」と入力してある行のM列からAT列まで色を白にする
L列に「入庫」と入力してある行のM列からAT列までを黄色にし、入っている項目を消す
L列に「在庫」と入力してある行のM列からAT列まで色を灰色にする
対象のシートを繰り返す
Sub リセット()
Dim maxrow As Long
Dim r As Long, ws As Worksheet
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Range("A1").Value = "在庫表" Then
maxrow = ws.Cells(Rows.Count, 12).End(xlUp).Row
For r = 4 To maxrow
If ws.Range("L" & r).Value = "出荷" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Pattern = xlNone
ElseIf Range("L" & r).Value = "入庫" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(255, 255, 153)
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ElseIf Range("L" & r).Value = "在庫" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(192, 192, 192)
ElseIf ws.Range("L" & r).Value = "その他" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(252, 213, 180)
End If
Next r
End If
Next
Application.ScreenUpdating = True
Range("A1").Select
MsgBox ("リセットが終了しました")
End Sub
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
（わからん） 2022/03/04(金) 15:59
（γ） 2022/03/04(金) 16:12
（γ） 2022/03/04(金) 16:18
→それぞれ約200行、合計で約600行でした。
γさん
Application.Calculation = xlCalculationManual
とし、最後で
Application.Calculation = xlCalculationAutomatic
と復旧させてみてはいかがでしょうか。
→こちらで試した所、1分位で完了しました。目からうろこ状態です！
ありがとうございます！
（こはのり） 2022/03/04(金) 18:16
そんなにあるんですね。
少なければ、全行ループして探すよりも検索して
特定したほうが速いと思ったので。
（わからん） 2022/03/04(金) 19:03
セルを処理する前に4行目のｋ列でフィルタをかけているものを外して
上記のマクロを実行し、それが終わったら再度Ｋ列でオートフィルタを設定し
次のシートに移るということをしたいのですが、そちらを下記の構文で
入れてもうまく実現できません。どちらに挿入するのが
正しいのでしょうか？度々恐縮ですが何卒よろしくお願いいたします。
↓マクロの説明
A1に「在庫表」と入力してあるシートを対象とし、
4行目のｋ列でフィルタをかけているものを外す。
L列に「出荷」と入力してある行のM列からAT列まで色を白にする
L列に「入庫」と入力してある行のM列からAT列までを黄色にし、入っている項目を消す
L列に「在庫」と入力してある行のM列からAT列まで色を灰色にする
4行目のｋ列で●がついているものを選択する。
対象のシートを繰り返す
Sub リセット2()
Dim maxrow As Long
Dim r As Long, ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
→ここに追加 Range("$A$4:$BI$705").AutoFilter Field:=11
If ws.Range("A1").Value = "在庫表" Then
maxrow = ws.Cells(Rows.Count, 12).End(xlUp).Row
For r = 4 To maxrow
If ws.Range("L" & r).Value = "出荷" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Pattern = xlNone
ElseIf Range("L" & r).Value = "入庫" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(255, 255, 153)
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ElseIf Range("L" & r).Value = "在庫" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(192, 192, 192)
ElseIf ws.Range("L" & r).Value = "その他" Then
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).ClearContents
ws.Range(ws.Cells(r, 13), ws.Cells(r, 46)).Interior.Color = RGB(252, 213, 180)
End If
Next r
End If
→ここに追加 Range("$A$4:$BI$705").AutoFilter Field:=11, Criteria1:="●"
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Range("A1").Select
MsgBox ("リセットが終了しました")
End Sub
（こはのり） 2022/03/04(金) 19:08
その観点から、もとのコード全般について見直しては？
また、
Select Case を使ったり、
With ws.Range(ws.Cells(r, 13), ws.Cells(r, 46))
などを使うことも検討されたらいかがですか？
（γ） 2022/03/04(金) 19:51
#コンパイルチェックしかしていないので、バグがあるかもしれません。
#フィルタはご自身でどうぞ。
Sub sample()
Dim maxRow As Long
Dim i As Long
Dim ws As Worksheet
Dim temp As Variant
Dim val As Variant
Dim targetRange As Range
Dim col As XlRgbColor
Dim isCear As Boolean
Dim isPaint As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
If ws.Range("A1").Value = "在庫表" Then
maxRow = ws.Cells(Rows.Count, "L").End(xlUp).Row
temp = ws.Range("L1").Resize(maxRow, 1).Value
For Each val In Array("出荷", "入庫", "在庫", "その他")
Set targetRange = Nothing
For i = 4 To maxRow
If temp(i, 1) = val Then
Select Case Not targetRange Is Nothing
Case True: Set targetRange = ws.Cells(i, "M").Resize(1, 34)
Case Else: Set targetRange = Union(targetRange, ws.Cells(i, "M").Resize(1, 34))
End Select
End If
Next i
If Not targetRange Is Nothing Then
Select Case val
Case "出荷"
isPaint = False
isCear = True
Case "入庫"
isPaint = True
col = rgbLightYellow
isCear = True
Case "在庫"
isPaint = True
col = rgbSilver
isCear = False
Case "その他"
isPaint = True
col = rgbMoccasin
isCear = True
End Select
With targetRange
If isPaint Then
.Interior.Color = col
Else
.Interior.Pattern = xlNone
End If
If isCear Then
.Value = ""
End If
End With
End If
Next val
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Range("A1").Select
MsgBox ("リセットが終了しました")
End Sub
（tkit） 2022/03/05(土) 00:09
（こはのり） 2022/03/05(土) 03:58
「標準モジュール」のコードでシートを指定しないRangeオブジェクトは、 その時にアクティブなシートのRangeとみなされます。（末尾の*も参考に)
ループ処理の中でwsは、次々に変わっていきますが、 その都度 wsをSelectしているわけではないので、 アクティブなシートはどれか一つに固定されたままです。
従って、
Range("$A$4:$BI$705").AutoFilter Field:=11
だとか、
ElseIf Range("L" & r).Value = "入庫" Then
といったシート指定がないものは、wsにあるセルとは別のシートのセルと解釈され、
本来の判定とは別の判定がされているはずです。
シート指定の省略は誤作動の原因となっていますので、修正する必要があります。
・Select Caseは分岐判定に使われるもので、IFで列挙していくより見やすいはずです。 ・また、ws.Range(ws.Cells(r, 13), ws.Cells(r, 46))が何度も出てきますが、 それぞれが同じものかどうか読む人が確認しなくてはならず、負荷を与えます。 見た目も良いものになりますので、活用されるとよいでしょう。
上の二つはワークシート指定の話とは違って、間違いということではありません。
こんな感じにするとよいと思います。（実際に動作確認していませんので、注意ください）
Sub test()
Dim maxrow As Long
Dim r As Long, ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
ws.Range("$A$4:$BI$705").AutoFilter Field:=11
If ws.Range("A1").Value = "在庫表" Then
maxrow = ws.Cells(Rows.Count, 12).End(xlUp).Row
For r = 4 To maxrow
With ws.Range(ws.Cells(r, 13), ws.Cells(r, 46))
Select Case ws.Range("L" & r).Value
Case "出荷"
.ClearContents
.Interior.Pattern = xlNone
Case "入庫"
.Interior.Color = RGB(255, 255, 153)
.ClearContents
Case "在庫"
.Interior.Color = RGB(192, 192, 192)
Case "その他"
.ClearContents
.Interior.Color = RGB(252, 213, 180)
End Select
End With
Next r
End If
ws.Range("$A$4:$BI$705").AutoFilter Field:=11, Criteria1:="●"
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "リセットが終了しました"
End Sub
少し前のバージョンを使って、ほぼ同程度の個数のデータで動作させてみましたが、 0.8秒くらいで終了しました。(1分というのは少し想像しにくかったですね。他のデータの影響でしょうか） この程度での件数では、あえてフィルタを使わなくてもよいのかなという印象です。
(*)参考 シートモジュールのコードでシート指定を省略した場合は、 アクティブシートがなんであれ、コードを書いた対象のシートが指定されたものとみなされます。 標準モジュールの場合とは違います。 （γ） 2022/03/05(土) 08:33
（γ） 2022/03/05(土) 08:42
（通りのいちゃもん） 2022/03/05(土) 08:54
確かに、For ループが何重にもネストしていて、
一番深いところから、何回か Exit Forしないといけない、
などという場合、例外的にGotoを考えることがありますが、
今回はむしろ、一番浅いところですので、それに該当する気はしませんね。
少なくとも私は。
（構造化プログラム、GOTOは避けよ、などというフレーズが真っ先に頭に浮かんでしまいます）
ありがとうございました。
（γ） 2022/03/05(土) 09:25
Dim ws As Worksheet
Dim maxrow As Long
Dim r As Long
Dim rng As Range
Dim cond As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
If ws.Range("A1").Value <> "在庫表" Then GoTo next_for
ws.Range("$A$4:$BI$705").AutoFilter Field:=11
maxrow = ws.Cells(Rows.Count, 12).End(xlUp).Row
For r = 4 To maxrow
Set rng = ws.Range(ws.Cells(r, 13), ws.Cells(r, 46))
cond = ws.Range("L" & r).Value
If cond <> "在庫" Then rng.ClearContents
If cond = "出荷" Then
rng.Interior.Pattern = xlNone
ElseIf cond = "入庫" Then
rng.Interior.Color = RGB(255, 255, 153)
ElseIf cond = "在庫" Then
rng.Interior.Color = RGB(192, 192, 192)
Else
rng.Interior.Color = RGB(252, 213, 180)
End If
Next
ws.Range("$A$4:$BI$705").AutoFilter Field:=11, Criteria1:="●"
next_for:
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "リセットが終了しました"
End Sub
（通りのいちゃんもん） 2022/03/05(土) 16:57
■１
内容からして↓の続きですよね。
[[20220110164859]] 『複数シートをマクロにて処理したい』（こはのり）
そちらでもおもいましたし、こちらでも同種のコメントがありますが必ずしも1行ずつ処理をする必要はないとおもいますよ。
すなわち
L列が【出荷】のものを一括して .ClearContents .Interior.Pattern = xlNone
L列が【入庫】のものを一括して .ClearContents .Interior.Color = RGB(255, 255, 153) .ClearContents
L列が【在庫】のものを一括して .Interior.Color = RGB(192, 192, 192) . L列が【その他】のものを一括して .ClearContents .Interior.Color = RGB(252, 213, 180)
のようにするという手もあるとおもいます。
のんびり書いている間にかぶってしまった感がありますが、例えばこんな感じです。
Sub 研究用1()
Stop
Dim maxrow As Long
Dim r As Long, ws As Worksheet
Dim tmpRNG As Range, buf As Variant, 色 As Long
For Each ws In Worksheets
With ws
If .Range("A1").Value = "在庫表" Then
Stop
For Each buf In Array("出荷", "入庫", "在庫", "その他")
Set tmpRNG = Nothing
For r = 4 To .Cells(.Rows.Count, "L").End(xlUp).Row
If .Cells(r, "L").Value = buf Then
If tmpRNG Is Nothing Then
Set tmpRNG = .Cells(r, "L")
Else
Set tmpRNG = Union(tmpRNG, .Cells(r, "L"))
End If
End If
Next r
If Not tmpRNG Is Nothing Then
Stop
Select Case buf
Case "出荷": 色 = xlNone
Case "入庫": 色 = RGB(255, 255, 153)
Case "在庫": 色 = RGB(192, 192, 192)
Case "その他": 色 = RGB(252, 213, 180)
End Select
Select Case buf
Case "出荷", "入庫", "その他"
Intersect(tmpRNG.EntireRow, .Range("M:AT")).ClearContents
Intersect(tmpRNG.EntireRow, .Range("M:AT")).Interior.Color = 色
Case "在庫"
Intersect(tmpRNG.EntireRow, .Range("M:AT")).Interior.Color = 色
End Select
End If
Next buf
End If
End With
Next ws
End Sub
■２
今回は、600行くらいとのことなので大丈夫かもしれませんが、"出荷", "入庫", "在庫", "その他"が飛び飛びに入り乱れていると「tmpRNG」に格納しきれなくなって、上記のアプローチだと上手くいかないかもしれません。
そのような場合には、既にアドバイスされているようにオートフィルタなどで抽出して処理をするというアプローチも有効であるとおもいます。
コードにするとこんな感じ。
Sub 研究用2()
Dim ws As Worksheet
Dim buf As Variant
For Each ws In Worksheets
If ws.Range("A1").Value = "在庫表" Then
Stop
ws.AutoFilterMode = False
ws.Range("L3:AT" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row).AutoFilter
For Each buf In Array("出荷", "入庫", "在庫", "その他")
Stop
ws.AutoFilter.Range.AutoFilter Field:=1, Criteria1:=buf
If ws.Cells(ws.Rows.Count, "L").End(xlUp).Row >= 4 Then
With Intersect(ws.AutoFilter.Range, ws.AutoFilter.Range.Offset(1)).SpecialCells(xlCellTypeVisible)
Stop
Select Case buf
Case "出荷"
.ClearContents
.Interior.Color = xlNone
Case "入庫"
.ClearContents
.Interior.Color = RGB(255, 255, 153)
Case "在庫"
.Interior.Color = RGB(192, 192, 192)
Case "その他"
.ClearContents
.Interior.Color = RGB(252, 213, 180)
End Select
End With
End If
Next buf
ws.AutoFilterMode = False
End If
Next ws
End Sub
■３
さらにL列の値で塗りつぶし色が変わればよいのであれば【条件付き書式】も有効だとおもいます。
（条件付き書式もマクロで設定することが可能です。）
Sub 研究用3()
Dim ws As Worksheet
Dim maxrow As Long, 行 As Long
Dim tmpRNG As Range
For Each ws In Worksheets
If ws.Range("A1").Value = "在庫表" Then
maxrow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
Set tmpRNG = Nothing
ws.Cells.FormatConditions.Delete
With ws.Range("L4:AT" & maxrow)
.FormatConditions.Add(Type:=xlExpression, Formula1:="=$L4=""入庫""").Interior.Color = RGB(255, 255, 153)
.FormatConditions.Add(Type:=xlExpression, Formula1:="=$L4=""在庫""").Interior.Color = RGB(192, 192, 192)
.FormatConditions.Add(Type:=xlExpression, Formula1:="=$L4=""その他""").Interior.Color = RGB(252, 213, 180)
End With
For 行 = 4 To maxrow
Select Case ws.Cells(行, "L").Value
Case "出荷", "入庫", "その他"
If tmpRNG Is Nothing Then
Set tmpRNG = ws.Cells(行, "L")
Else
Set tmpRNG = Union(tmpRNG, ws.Cells(行, "L"))
End If
End Select
Next 行
If Not tmpRNG Is Nothing Then Intersect(tmpRNG.EntireRow, ws.Range("M:AT")).ClearContents
End If
Next ws
End Sub
■４
ということを踏まえると以下を考慮してイチから考え直してみると新たな発見があるかもしれません。
・対象のオブジェクトをきちんと指定する ・極力まとめて操作することを考える
（もこな２） 2022/03/05(土) 22:02
やりたいことは、
「ブックの中のシートを巡回してシートを初期化をする」
ということだと思います。
ならば、
Sub test()
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In Worksheets
If ws.Cells(1).Value = "在庫表" Then
シート初期化 ws
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
これだけのコードになると思います。
で、、「シートの初期化」とはどういうことかを、
別のプロシージャで定義します。
Sub シート初期化(ByRef ws As Worksheet)
Dim rngTable As Range
Dim rngTarget As Range
Set rngTable = ws.AutoFilter.Range
Set rngTarget = intersert(ws.Range("M:AT"), rngTable, rngTable.Offset(1))
rngTarget.Interior.Color = rgbGray
With rngTable
.AutoFilter Field:=11, Criteria1:="<>在庫"
.ClearContents
.AutoFilter Field:=11, Criteria1:="入庫"
rngTarget.Interior.Color = vbYellow
.AutoFilter Field:=11, Criteria1:="その他"
rngTarget.Interior.Color = vbBlue
.AutoFilter Field:=11, Criteria1:="出荷"
rngTarget.Interior.ColorIndex = xlColorIndexNone
.AutoFilter Field:=11, Criteria1:="●"
End With
End Sub
※オートフィルターで非表示のセルの、セルの書式設定が無効なのか有効なのか
分かりませんが、こんな感じでいいのでは？
このままでだめならジャンプ機能でセル範囲を絞り込めばよいかと思います。
（エラー回避処理は省略）
※参考です。うまく動くかは未検証です。
考え方の助力になれば。。。。
（まっつわん） 2022/03/06(日) 09:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.