ここから本文です

知恵袋で教えてもらいました。 マクロなのですが一行ごとの意味を教えて下さい。

dfc********さん

2019/11/422:28:02

知恵袋で教えてもらいました。
マクロなのですが一行ごとの意味を教えて下さい。

Sub Test()

Dim lastrow As Long
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim NGrng As Range

lastrow = Cells(Rows.Count, 10).End(xlUp).Row

For i = 1 To lastrow
For j = 1 To Cells(i, 10)
If Cells(i, j) = "b" Or Cells(i, j) = "c" Or Cells(i, j) = "d" Then
If cnt = 0 Then
Set NGrng = Cells(i, j)
ElseIf cnt > 0 Then
Set NGrng = Union(NGrng, Cells(i, j))
End If
cnt = cnt + 1
ElseIf Cells(i, j) = "a" Or Cells(i, j) = "" Then
If cnt >= 3 Then
NGrng.Interior.ColorIndex = 3
End If
cnt = 0
Set NGrng = Nothing
End If
Next j
Next i

End Sub

閲覧数:
133
回答数:
3

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

taihenda****さん

2019/11/511:36:20

解説は他の方にお任せするとして、
面白そうなので配列でやってみました。配列にすると数倍速くなると見込めます。
試してみてください。(10万行で勝手に作ったサンプルで2,3秒)

添付図の罫線は条件付き書式です。

Dictionaryの配列が使えるかどうか私にはわかりませんが使えるならもっと速くなりそうです。



Sub Test()
Dim i As Long, j As Long, k As Long, n As Long
Dim D1, D2
n = Application.Sum(Range("J:J"))
ReDim D1(1 To n, 1 To 3)
ReDim D2(1 To n, 1 To 2)
For i = 1 To Cells(Rows.Count, 10).End(xlUp).Row
For j = 1 To Cells(i, 10)
k = k + 1
D1(k, 1) = Cells(i, j)
D1(k, 2) = i
D1(k, 3) = j
Next
Next
k = 1
For i = 1 To n - 2
If D1(i, 1) <> "" And D1(i, 1) <> "a" _
And D1(i + 1, 1) <> "" And D1(i + 1, 1) <> "a" _
And D1(i + 2, 1) <> "" And D1(i + 2, 1) <> "a" Then
D2(k, 1) = D1(i, 2)
D2(k, 2) = D1(i, 3)
D2(k + 1, 1) = D1(i + 1, 2)
D2(k + 1, 2) = D1(i + 1, 3)
D2(k + 2, 1) = D1(i + 2, 2)
D2(k + 2, 2) = D1(i + 2, 3)
k = k + 3
End If
Next
Application.ScreenUpdating = False
For i = 1 To k - 1
Cells(D2(i, 1), D2(i, 2)).Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub

解説は他の方にお任せするとして、
面白そうなので配列でやってみました。配列にすると数倍速くなると見込めます。...

  • 質問者

    dfc********さん

    2019/11/812:43:12

    ありがとうございます。
    すみません大変恐縮なのですが…

    J列をBI列に移動して
    A~P列は文字列として無視してQ列~判定(Q列以降にランクが書いてある)する。
    ランクのA,B,C,DをC,B,A1,A2に替える
    連続箇所を文字色を赤にする。(B,A1,A2が三つ以上の連続箇所)

    自分でやろうとしてもなかなかうまくいかなくって
    大変恐縮なのですがよろしくお願いします。

    ちなみにこれはレールのマクラギのランクです。
    連続不良個所は危険です。

  • その他の返信(1件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2019/11/8 13:49:06

お手間な事をお願いしました。
大変ありがとうございます。
早速試してみます。
皆さま心よりありがとうございました。

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

30246kikuさん

2019/11/712:07:15

説明は既にされているので、危ないところと、別記述でチョイ速く・・・

危ないところ

For ループを抜けた後、cnt >= 3 の処理をしないと、
最後の色付けがうまく行われないので、以下3行追加しておかないと・・・

> Next j
> Next i

If cnt >= 3 Then
   NGrng.Interior.ColorIndex = 3
End If


別記述

Samp2 では、提示あった記述の Union 処理を変更したもの
色付け候補の、行(i)、列(j) を jR() および jC() に覚えておく
どこまで覚えた? を、変数 m で
m が 3 以上なら、覚えていた jR、jC で単純に色付け
覚える・覚えない がコロコロ変わる場合、Union より単純・・・が速い

Samp1 では、Samp2 で値比較時1つずつセル参照しており、
比較する値をまとめて入手しておけば、それなりに速くなる
> このコードは100万件のデータには少し時間がかかり過ぎる
より、一気に入手するとメモリ的に大丈夫?があるため、
1回に読み込む行数を
>   Const CRSZ As Long = 5000 ' 1回の処理行
で定義しておき、処理する行範囲を変更しながら、まとめて値を入手する
この読み込んだ範囲の背景色を一気に覚える様に jR、jC も確保しておく


確認は、

新規ブックを開き、標準モジュールに以下を記述する
testData を実行して、確認用データを作成する
Samp1 or Samp2 を実行してみる

現状の testData を実行すると、
2000 行のデータを作成後、そのパターンを 100000 行までコピーする
その後、実行してみると以下雰囲気

Samp1: 14 秒
Samp2: 19 秒
提示あった記述: 25 秒
新Test: 30 秒

>         Select Case Int(15 * Rnd()) ' ★

         Select Case Int(30 * Rnd()) ' ★

と、空欄を多くしたデータを作成後では以下雰囲気

Samp1: 3 秒
Samp2: 7.5 秒
提示あった記述: 19.5 秒
新Test: 8 秒

そのままで、さらに、

>   Const CRC As Long = 100000 ' 全行数 (CRH の倍数)

   Const CRC As Long = 1000000 ' 全行数 (CRH の倍数)

と行数を 1000000 行にしたデータでは雰囲気

Samp1: 28 秒


※ 背景色を設定するセル数が少ないほど速くはなる
※ もっと速くする方法があるかも??

※ ☆ の行は、バフッとした時間測定用(実際には不要)

※ J 列 → X 列、A 列~ → D 列~ への変更は
▼ の行をコメントにし、その下の行を有効にするだけで・・・・


※ 説明が必要なら、返信頂ければと


どうなりますか


Option Explicit

Public Sub Samp1()
   Dim vA As Variant, vC As Variant
   Dim jR() As Long, jC() As Long
   Dim jP As Long, jRh As Long, jCw As Long
   Dim i As Long, j As Long, k As Long, n As Long, m As Long
   Const CRSZ As Long = 5000 ' 1回の処理行
   Const CCC As Long = 3 ' 判別連続数
   Dim st As Single ' ☆
   st = Timer() ' ☆

   Application.ScreenUpdating = False
   With Range("J1", Cells(Rows.Count, "J").End(xlUp)) ' ▼
'   With Range("X1", Cells(Rows.Count, "X").End(xlUp))
      jRh = .Count
      jCw = WorksheetFunction.Max(.Cells)
      ReDim jR(1 To (CRSZ + CCC) * jCw)
      ReDim jC(1 To (CRSZ + CCC) * jCw)
      jP = 1

      While (jRh > 0)
         k = jRh
         If (k > CRSZ) Then k = CRSZ + CCC
         If (k = 1) Then
            ReDim vC(1 To 1, 1 To 1)
            vC(1, 1) = .Cells(jP).Value
         Else
            vC = .Cells(jP).Resize(k).Value
         End If

         With .EntireRow.Cells(jP, "A") ' ▼
'         With .EntireRow.Cells(jP, "D")
            vA = .Resize(k, jCw).Value
            n = 0: m = 0
            For i = 1 To k
               For j = 1 To vC(i, 1)
                  Select Case vA(i, j)
                     Case "b", "c", "d"
                        m = m + 1
                        jR(n + m) = i
                        jC(n + m) = j
                     Case Else
                        If (m >= CCC) Then n = n + m
                        m = 0
                  End Select
               Next
            Next
            If (m >= CCC) Then n = n + m
            For i = 1 To n
               .Cells(jR(i), jC(i)).Interior.ColorIndex = 3
            Next
         End With
         jP = jP + CRSZ
         jRh = jRh - CRSZ
      Wend
   End With
   Application.ScreenUpdating = True
   MsgBox Timer() - st ' ☆
End Sub


Public Sub Samp2()
   Dim vC As Variant
   Dim iR() As Long, jC() As Long
   Dim i As Long, j As Long, k As Long, n As Long, m As Long
   Const CCC As Long = 3 ' 判別連続数
   Dim st As Single ' ☆
   st = Timer() ' ☆

   n = 99
   ReDim iR(1 To n)
   ReDim jC(1 To n)

   Application.ScreenUpdating = False
   With Range("J1", Cells(Rows.Count, "J").End(xlUp)) ' ▼
'   With Range("X1", Cells(Rows.Count, "X").End(xlUp))
      vC = .Value
      With .EntireRow.Cells(1, "A") ' ▼
'      With .EntireRow.Cells(1, "D")
         m = 0
         For i = 1 To UBound(vC)
            For j = 1 To vC(i, 1)
               Select Case .Cells(i, j).Value
                  Case "b", "c", "d"
                     m = m + 1
                     If (m > n) Then
                        n = n * 2
                        ReDim Preserve iR(1 To n)
                        ReDim Preserve jC(1 To n)
                     End If
                     iR(m) = i
                     jC(m) = j
                  Case Else
                     If (m >= CCC) Then
                        For k = 1 To m
                           .Cells(iR(k), jC(k)) _
                              .Interior.ColorIndex = 3
                        Next
                     End If
                     m = 0
               End Select
            Next
         Next

         If (m >= CCC) Then
            For k = 1 To m
               .Cells(iR(k), jC(k)).Interior.ColorIndex = 3
            Next
         End If
      End With
   End With
   Application.ScreenUpdating = True
   MsgBox Timer() - st ' ☆
End Sub


' 確認用データ作成

Public Sub testData()
   Const CRC As Long = 100000 ' 全行数 (CRH の倍数)
   Const CRH As Long = 2000 ' 作成する行数 (残りはコピー)
   Const CCW As Long = 10 ' 全体列数
   Dim vA(1 To CRH, 1 To CCW) As Variant
   Dim i As Long, j As Long

   Randomize

   For i = 1 To CRH
      vA(i, CCW) = Int((CCW - 2) * Rnd()) + 1
      For j = 1 To vA(i, CCW)
         Select Case Int(15 * Rnd()) ' ★
            Case 1, 2, 3: vA(i, j) = "b"
            Case 4, 5, 6: vA(i, j) = "c"
            Case 7, 8, 9: vA(i, j) = "d"
            Case 11, 12, 13: vA(i, j) = "a"
         End Select
      Next
   Next

   Application.ScreenUpdating = False
   Cells.Delete
   With Range("A1").Resize(CRH, CCW)
      .HorizontalAlignment = xlCenter
      .Value = vA
      For i = 1 To CRH
         .Cells(i, 1).Resize(, vA(i, CCW)) _
            .Borders.LineStyle = xlContinuous
      Next
      .Columns(CCW).Borders.LineStyle = xlContinuous
      .Copy .Offset(CRH).Resize(CRC - CRH)
      .EntireColumn.AutoFit
   End With
   Application.ScreenUpdating = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

プロフィール画像

カテゴリマスター

hot********さん

2019/11/502:16:48

他の人のプログラムを説明すると言うのもなんですが、質問の方も見ましたが、こんな説明でどうでしょうか。


Sub Test()
Dim lastrow As Long '最終行用
Dim i As Long '行カウント用
Dim j As Longg '列カウント用
Dim cnt As Long '対象セル数
Dim NGrng As Range '対象セル
lastrow = Cells(Rows.Count, 10).End(xlUp).Row '10列(J列)最終行
For i = 1 To lastrow '注目行を1行目から10列(J列)最終行まで(縦回数)
For j = 1 To Cells(i, 10) '注目列を1列目から注目行10列目(J列)の値まで(横回数)

If Cells(i, j) = "b" Or Cells(i, j) = "c" Or Cells(i, j) = "d" Then '注目セル(注目行、注目セル)の値が"bcd"なら
If cnt = 0 Then '対象セルの数が0なら
Set NGrng = Cells(i, j) 'NGrngに注目セルを設定
ElseIf cnt > 0 Then '対象セルの数が0より多ければ
Set NGrng = Union(NGrng, Cells(i, j)) 'NGrngに注目セルを追加
End If
cnt = cnt + 1 '対象セルの数+1(注目セルが"bcd"なら+1)
ElseIf Cells(i, j) = "a" Or Cells(i, j) = "" Then '注目セル(注目行、注目セル)の値が"a"か空白なら
If cnt >= 3 Then '対象セルの数が3以上なら(cntは"bcd"のセルで+1されるので、ここでcntが3以上と言う事は、1つ前まで"bcd"が3回以上連続)
NGrng.Interior.ColorIndex = 3 'NGrngセルの背景赤
End If
cnt = 0 '対象セルの数=0(注目セルが"a"か""なら0)
Set NGrng = Nothing '対象セルなし(注目セルが"a"か""ならNothing(なし))
End If
Next j '列を繰り返す
Next i '行を繰り返す
End Sub





このプログラムの肝の制御系が2つある。
10列(J列)に各行の対象セル数が入っているので、J列の最終行まで(For i=1 To lastrow)の各行でJ列の値のセル(For j = 1 To Cells(i, 10))がチェック対象のセルになる。

Sub Test()
Dim lastrow As Long '最終行用
Dim i As Long '行カウント用
Dim j As Longg '列カウント用
Dim cnt As Long '対象セル数
Dim NGrng As Range '対象セル
lastrow = Cells(Rows.Count, 10).End(xlUp).Row '10列(J列)最終行
For i = 1 To lastrow '注目行を1行目から10列(J列)最終行まで(縦回数)
For j = 1 To Cells(i, 10) '注目列を1列目から注目行10列目(J列)の値まで(横回数)
'cells(i,J)が対象セル
Next j '列を繰り返す
Next i '行を繰り返す
End Sub





チェック対象の各セルで "bcd"の時はcntを+1、"a"か""の時はcnt=0しているので、常時"bcd"の連続数が分かる。
チェック対象のセルが"a"か""でcntが1以上の場合は、1つ前が"bcd"と言う事なので、ここでcntが3以上かチェックして背景色を変えている。

If Cells(i, j) = "b" Or Cells(i, j) = "c" Or Cells(i, j) = "d" Then '注目セル(注目行、注目セル)の値が"bcd"なら
'処理
cnt = cnt + 1 '対象セルの数+1(注目セルが"bcd"なら+1)
ElseIf Cells(i, j) = "a" Or Cells(i, j) = "" Then '注目セル(注目行、注目セル)の値が"a"か空白なら
'3連続の処理
cnt = 0 '対象セルの数=0(注目セルが"a"か""なら0)
End If

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる