[[20190107134018]]　『ループ処理』（トム）　ページの最後に飛ぶ

『ループ処理』（トム）

お世話になります。
冶具の管理をしていますが、年度末に向け廃棄冶具の選定をするために
ご教授お願いいたします。

行数は約60000行で最小4行、最大18行で19行間隔で作表してあります。
データの範囲はA2からX20以降19行間隔であります。

X行に貸し出し回数が有り、貸し出し回数の少ないものが廃棄対象になるので
色を付けて見やすくしたいと思っております。

貸しだし回数が
1なら赤で太文字
2なら青で太文字
3なら黄で太文字
4と5は緑で太文字
この時L列からX列まで上記の条件で処理をしたいのですが可能でしょうか？
宜しくお願い致します。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 条件付書式でできると思います。
 60000行もあると、ループでは時間かかりますよ。
（TAKA） 2019/01/07(月) 14:17

TAKA様
コメントありがとうございます。

時間は掛かっても構わないのでマクロでお願いしたいのですが・・・
どの様に処理するかを勉強したいのでお願いします。
（トム） 2019/01/07(月) 15:15

Sub main()

    Dim c As Range, r As Range
    Columns("L:X").Font.ColorIndex = xlAutomatic
    Columns("L:X").Font.Bold = False
    For Each c In Range("X:X").SpecialCells(2, 1)
        Set r = c.Offset(, -12).Resize(, 13)
        Select Case c.Value
            Case 1: r.Font.Color = vbRed: r.Font.Bold = True
            Case 2: r.Font.Color = vbBlue: r.Font.Bold = True
            Case 3: r.Font.Color = vbYellow: r.Font.Bold = True
            Case 4, 5: r.Font.Color = vbGreen: r.Font.Bold = True
        End Select
    Next c
End Sub
（mm） 2019/01/07(月) 15:47

mm様
コードありがとうございます。

ループ処理せずに一気に処理するとは考えていませんでした。
表を一つのブロックとして考えていたもので驚きました。

結果は満足ですが、for　nextのコードも勉強の為に見たい気もします。
可能であれば教えて頂けると助かります。
（トム） 2019/01/07(月) 18:01

 For Each c ～
　　・・・
 next c

で、for　nextで処理していますが。

（mm） 2019/01/07(月) 18:13

 60,000行って結構ありますね・・・
 mmさんのコードでも、一回フリーズしちゃいやした。

 For～Nextステートメントですが、セルをバリバリやると時間かかりそうだったので、
 Unionでまとめました。
 連続したセル範囲だと60,000行問題なくできましたが、
 飛び地を入れていくと途中でフリーズしてしまうので
 1,000行ごとに処理にしました。

 色付けると、ものすごく見えにくいですね。
 いっそ貸出回数が少ないものを別のシートにまとめてはどうですか？

    Sub 色付け()
        Dim i As Long
        Dim w As Variant
        Dim rng(1 To 5) As Range
        Dim j As Long
        w = Range("X1", Cells(Rows.Count, "X").End(xlUp)).Value
        Columns("L:X").Font.ColorIndex = xlAutomatic
        Columns("L:X").Font.Bold = False
        For i = 2 To 60000
            Select Case w(i, 1)
                Case 1, 2, 3, 4, 5
                    If rng(w(i, 1)) Is Nothing Then
                        Set rng(w(i, 1)) = Range(Cells(i, "L"), Cells(i, "X"))
                    Else
                        Set rng(w(i, 1)) = Union(Range(Cells(i, "L"), Cells(i, "X")), rng(w(i, 1)))
                    End If
                Case Else
                    '何もしない
            End Select
            'If i Mod 500 = 0 Then Stop
            If i Mod 1000 = 0 Then
                For j = 1 To 5
                    If Not rng(j) Is Nothing Then
                        With rng(j).Font
                            .Color = Array("dummy", vbRed, vbBlue, vbYellow, vbGreen, vbGreen)(j)
                            .Bold = True
                        End With
                        Set rng(j) = Nothing
                    End If
                Next j
                DoEvents
            End If
        Next i
    End Sub

（稲葉） 2019/01/07(月) 19:32

試してませんが、オートフィルタでできませんか？

（マナ） 2019/01/07(月) 19:45

 マナさん
 表が提示されてないので確証はないのですが、
 矩形の表が何段にも重なっているのではないかな、と
 推測してます。

 それでもフィールド名さえあれば行けそうですけどねー
（稲葉） 2019/01/07(月) 20:33

誤解していなければ、表がいくつあっても関係ないような…

１）L列からX列全体を選んでフィルタ
２）X列が１を抽出
３）文字を赤で太字
４）X列が２を抽出
５）文字を青で太字

のような感じで繰り返して

１行目がフィールド名でもデータでも
とりあえず無視、最後にあるべき色に修正。

手作業だと２分くらいできそうに思ったのですが。

（マナ） 2019/01/07(月) 21:08

mm様、稲葉様、マナ様
コメント及びコードありがとうございます。
mm様の最初のコードもFor nextでした。固定概念を持って処理するのはよくないですね。失礼しました。
稲葉様のコードはまだ試していませんが構造をリバースエンジニアリングで勉強させていただきます。
会社の要求で色々出てきそうなのでワガママを言ってしまいました。
マナ様のおしゃったオートフィルターも勉強してみます。
mm様のコードで無事色付けが時間はかかりましたが完了しました。
御協力ありがとうございました。
（トム） 2019/01/07(月) 21:16

application.screenupdating=falseを入れれば多少はマシになるかもしれません。
（mm） 2019/01/08(火) 09:02

コメント返信：

[ 一覧(最新更新順) ]

[[20190107134018]] 『ループ処理』（トム） ページの最後に飛ぶ

[[20190107134018]]　『ループ処理』（トム）　ページの最後に飛ぶ