Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2007)
EXCEL VBAの条件指定しての行検索
投稿日時: 18/07/10 15:55:06
投稿者: FILETUBE

こんにちは。
EXCEL VBAの条件指定しての行検索についてお聞きします。
 
品番入力  B
カラー入力 2   訂正ボタン
 
品番 カラー 項目  履歴
A 1 113  0
A 2 223 0
A 3 333 0
B 1 113 0
B 2 223 0
B 3 333 0
C 1 113 0
C 2 223 0
C 3 333 0
 
上記のようなEXCELのシートがあります。
1行目、2行目で検索する条件を入力し
その横に訂正ボタンをクリックすると
5行目からのデータを検索して
該当するデータが見つかった場合、その行を
黄色に塗りつぶし、その下に1行挿入したいのです。
 
その挿入した1行には別のEXCELからデータをセットし
履歴はプラス1します(最新の意味で)
 
品番 カラー 項目  履歴
A 1 113  0
A 2 223 0
A 3 333 0
B 1 113 0
B 2 223 0 ←この行を塗りつぶし
B 2 999 1
B 3 333 0
C 1 113 0
C 2 223 0
C 3 333 0
  
 
このよう処理を行う場合、品番、カラーを入力した後
一致するデータを検索し、塗りつぶしをしたいのですが
複数行あった場合は履歴の値が一番大きな行になります。
 
まず一致する行の検索ですが、みなさんなら
どのような方法をとりますか?
 
Findでしょうか?
 
分かる方おられましたら教えて頂けないでしょうか。
宜しくお願いします。

回答
投稿日時: 18/07/10 16:05:58
投稿者: mattuwan44

フィルターオプションを使うかなぁ。。。
 
ただし、
条件を入力する表は、

品番入力	カラー入力
B	       2

と、行列を入れ替えます。
 
まぁ、マクロにするなら、逆でもどうにでもなりますが、
エクセルのやり方を踏襲して慣れておいた方が、
手間が少ないかとは思います。
 
で、検索は上から見て最初に出てきたものだけですか?
同じものが複数あれば、同じように処理するのですか?

投稿日時: 18/07/10 21:02:12
投稿者: FILETUBE

回答ありがとうございます。
履歴番号で管理しようと思いますので、
重複はないものと考えています。
万が一、重複があった場合は運用者に知らせて
処理は1度のみです。
 
処理はVBAで行いたいのですが
まず検索の方法で意見を聞きたく
投稿しました。
 
よろしくお願いします。
 

投稿日時: 18/07/11 17:46:31
投稿者: FILETUBE

参考になるサイトを見つけ
下記のようにコーディングしました。
 
 
Private Sub ボタン1_Click()
 
Dim c As Range
For Each c In Range("A5:B12")
    ' 第一条件
    If c.Value <> Range("A2").Value Then
        GoTo Continue
    End If
    ' 第二条件
    If c.Offset(0, 1).Value <> Range("B2").Value Then
        GoTo Continue
    End If
    '*** 条件合致処理 ***
    Dim aValue As String
    aValue = c.Offset(0, 3).Value
    '合致行塗りつぶし
    c.Interior.Color = RGB(100, 255, 255)
    Exit For
    
Continue:
    Next
 
End Sub
 
A2,B2のセルで条件を入力し、合致する行は検索できるようになりましたが
 
次に行いたいことが有ります。
 
@ A列からD列まで合致行塗りつぶしをしたい
A合致行のすぐ下に1行追加したい
 
のまず2点です。
上記のコードをどのように訂正するとよいのか
分かる方おられましたら教えて頂けないでしょうか。
 
どうぞ宜しくお願いします。
 

回答
投稿日時: 18/07/11 20:38:51
投稿者: simple

こんばんは。
 
> @A列からD列まで合致行塗りつぶしをしたい
> A合致行のすぐ下に1行追加したい
> のまず2点です。
> 上記のコードをどのように訂正するとよいのか

結果のコードだけを求めるのではなく、
手法をマスターするようにしてください。
 
(1)それぞれ簡単な例にして、マクロ記録をとってみます。
(2)それに手を入れて修正します。
こういう方針で取り組んでみてはいかがですか?
(VBAの学習の仕方を書いた本にはこうしたことが書いてあるはずです。
だまされたと思って、そのとおりにやってみてください。)
 
(1)だけで(2)に進めなかったら、(1)の結果を示してみてください。

回答
投稿日時: 18/07/11 20:46:37
投稿者: mattuwan44

ども^^
 
まずは、フィルターオプションを使った例
 
シートのイメージはこんな感じにして、
 

品番	カラー		
B	2		

品番	カラー	項目	履歴
A	1	113	0
A	2	223	0
A	3	333	0
B	1	113	0
B	2	223	0
B	3	333	0
C	1	113	0
C	2	223	0
C	3	333	0

 
 
 
 
とりあえずマクロの記憶の結果
 
Sub Macro2()
'
' Macro2 Macro
' マクロ記録日 : 2018/7/11 ユーザー名 : ma
'
 
'
 
    Range("A4:D13").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
                                   Range("A1:B2"), Unique:=False
    Range("A9:D9").Select
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    ActiveSheet.ShowAllData
End Sub
 
↑を参考に組み立てたら、↓こんな感じ
 
Sub test()
    Dim rngList As Range
    Dim rngCriteria As Range
    Dim rngFoundCells As Range
    Dim rngNew As Range
 
    '準備
    Set rngList = Range("A4").CurrentRegion
    Set rngCriteria = Range("A1").CurrentRegion
     
    'セルの検索
    With rngList
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set rngFoundCells = Intersect(.SpecialCells(xlCellTypeVisible), .Offset(1))
            .Worksheet.ShowAllData
        End If
    End With
     
    '見つかった行の操作
    If Not rngFoundCells Is Nothing Then
        With rngFoundCells
            .Interior.Color = vbYellow
            Set rngNew = .Resize(1).Offset(.Rows.Count)
        End With
        rngNew.Insert shift:=xlDown
        With rngNew.Offset(-1)
            .Interior.ColorIndex = xlNone
            'ここでどこからかコピペ?
            .Cells(4).Value = .Cells(-1, 4).Value + 1
        End With
    End If
End Sub
 
提示のコードは、どなたかにご指摘を期待。疲れた^^;

投稿日時: 18/07/11 21:52:10
投稿者: FILETUBE

こんばんは。
なるほど、マクロの記録の手法は
忘れていました。
 
早速確認したいと思います。

投稿日時: 18/07/12 14:27:11
投稿者: FILETUBE

mattuwan44さん、回答ありがとうございました。
 
機能をもう少し追加したいのでが
もう少し教えて頂けないでしょうか。
 
 
@下に1行挿入され履歴が1となりますが
 もう1度処理を行った場合、今度は履歴を
 2にしたいのです。
 
A検索の条件に項目を3個指定できるように
 したいのですが、1つ目のみしか 
 検索できません。
 
 
この場合、どのような訂正になるのでしょうか。
 
大変申し訳ありませんが、どうぞ宜しくお願いします。

回答
投稿日時: 18/07/12 20:22:14
投稿者: WinArrow
投稿者のウェブサイトに移動

色をつけるところまでのサンプルコード
 
 
Sub sample()
Dim KEYA As String, KEYB As Long
 
Dim SROW As Long
Dim SCNT As Long
Dim BROW As Long
 
With ActiveSheet
    KEYA = .Range("A2").Value
    KEYB = .Range("B2").Value
    SCNT = WorksheetFunction.CountIf(.Range("A5:A12"), KEYA)
    SROW = WorksheetFunction.Match(KEYA, .Range("A5:A12"), 0)
    BROW = WorksheetFunction.Match(KEYB, .Range("B" & SROW + 5).Resize(SCNT), 0)
    .Cells(BROW + SROW + 4, "C").Interior.Color = vbRed
End With
End Sub

投稿日時: 18/07/12 21:42:50
投稿者: FILETUBE

回答ありがとうございます。
検索条件の1は必須入力で、検索条件の2,3は任意とします。
未入力の場合は全てが対象となります。
検索条件の3は入力が最大3まで可能です。
フィルターオプションの手法を教えて
もらいましたが、For eachでloopの手法の方が
良いですか?
 

回答
投稿日時: 18/07/12 22:58:06
投稿者: mattuwan44

Sub test()
    Dim rngList As Range
    Dim rngCriteria As Range
    Dim rngFoundCells As Range
    Dim rngNew As Range
  
    '準備
    Set rngList = Range("A4").CurrentRegion
    Set rngCriteria = Range("A1").CurrentRegion
      
    'セルの検索
    With rngList
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set rngFoundCells = Intersect(.SpecialCells(xlCellTypeVisible), .Offset(1))
            .Worksheet.ShowAllData
        End If
    End With
    If rngFoundCells.Rows.Count = 3 Then
        MsgBox "最大数になっています。処理を中断。"
        Exit Sub
    End If
         
      
    '見つかった行の操作
    If Not rngFoundCells Is Nothing Then
        With rngFoundCells
            .Rows(.Rows.Count).Copy
            .Rows(.Rows.Count + 1).Insert
            With .Rows(.Rows.Count + 1)
                .Interior.Color = vbYellow
                .Cells(.Cells.Count).Value = .Cells(.Cells.Count).Value + 1
            End With
        End With
    End If
End Sub

回答
投稿日時: 18/07/13 12:25:53
投稿者: mattuwan44

あぁ、敢えて検索とか抽出とかしなくてもいいのかな?
最終行に追加して、並び替えをしてしまえばよさそう。
履歴は並び替えた後、空白を探してそこに書き込めばよさそうですね。

回答
投稿日時: 18/07/14 08:55:27
投稿者: simple

少し間が空いてしまいましたが、いくつかコメントします。
 
(1)
18/07/11 20:38:51でマクロ記録の活用を提案しました。
それはどうなったのでしょうか。
 
(2)
その時は18/07/11 17:46:31で提示された繰り返しを使ったコードに
あえてコメントしませんでしたが、指摘したほうが良い点はもちろんあります。
・対象のセル範囲にB列が含まれているのは無駄です。A列だけにすべきでしょう。
・Gotoを使うのは感心しません。
  この場合、

   If c.Value = Range("A2").Value Then
        If c.Offset(0, 1).Value = Range("B2").Value Then
            '*** 条件合致処理 ***
            c.Interior.Color = RGB(100, 255, 255)
        End If
    End If
などとすればGotoは避けられます。(処理内容の妥当性は別として)
 
(3)
> A検索の条件に項目を3個指定できるように
>  したいのですが、1つ目のみしか 
>  検索できません。
> この場合、どのような訂正になるのでしょうか。
この部分ですが、これだけでは質問になっていません。
3個指定するなら、
・少なくとも、「検索条件範囲」の指定はどう変更したのか、
・また、どんな検索条件なのか
の具体的な提示がなければ意味がまったくわかりません。
改良する出発点を示すのはあなたの仕事です。
これでは正直、愚痴を言っているレベル(いや失礼)としか言われかねません。
 
また、フィルタオプションで条件に関係させない項目はブランクにしておくだけで
よいはずです。
このあたり、フィルタオプションそのものをよく学習されたほうがよいですね。
 
改良すべきとして、現状そのものをまずはしっかり提示してください。
 
(4)
議論の出発点のところですが、
>B 2 223 0 ←この行を塗りつぶし
>B 2 999 1
とすると、次回検索では、品番(B)カラー(2)は複数マッチしますね。
このように、複数マッチして、履歴カウンターが最大のものだけ相手にする処理は
必要ではないのですか?
修正された元のデータは処理後に削除するので、
複数にはならない、ということならそのように書かないと分かりません。
なにか、このあたりの話が不明確のまま進行している印象です。
ま、外野から余計な心配する必要もないのだろうが。

回答
投稿日時: 18/07/14 09:23:19
投稿者: simple

指摘だけするのも何かと思いまして、
フィルタオプションを使ったコードを参考までに掲載します。
すでに頂いている回答とダブっていまして恐縮です。
 

Sub test()
    Dim myR As Range
    Dim r As Range
    Dim myMax As Long

    'フィルタオプション
    Range("A4").CurrentRegion.AdvancedFilter _
            Action:=xlFilterInPlace, _
            CriteriaRange:=Range("A1:B2"), Unique:=False

    'A列の可視セル
    Set myR = Range("A4").CurrentRegion.Columns(1)
    Set myR = Intersect(myR.Offset(1), myR).SpecialCells(xlCellTypeVisible)

    '履歴の最大値
    myMax = WorksheetFunction.Max(myR.Offset(, 3))

    For Each r In myR
        If r.Offset(, 3).Value = myMax Then ' 履歴が最大のものだけ対象
            '一行挿入
            r.Offset(1).EntireRow.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            r.Offset(1, 3).Value = myMax + 1
            '色をつける
            r.Resize(1, 4).Interior.Color = vbYellow
        End If
    Next
    ActiveSheet.ShowAllData
End Sub

何分、質問のあった日に書いたものなので、その後の仕様変更に対応していないかもしれません。
あしからずご了解ください。

投稿日時: 18/07/16 17:07:44
投稿者: FILETUBE

回答ありがとうございます。
ご指摘の通り、そのままでは無限ループに
なってしまいますので、挿入した行にフラグをセットし
その行はスキップするようにしました。
第1条件は必須で第2条件は任意、また第3条件も任意で
入力項目は3つあります。
このような仕様の時に、フィルタオプションが
使えるのか正直わかっていません。
 
Gotoの件は訂正します。
 
皆さん色々ありがとうございます。

回答
投稿日時: 18/07/16 19:24:33
投稿者: simple

無限ループというのも何についての話かわかりませんし、
今、課題となっていることが何なのか、さっぱりわかりません。
箇条書きで説明していただけないですか?
回答を待つだけでなく、課題を明確にしていただきたいですね。

回答
投稿日時: 18/07/16 19:53:01
投稿者: mattuwan44

>このような仕様の時に、フィルタオプションが
>使えるのか正直わかっていません。
 
やってみればいいのでは?
 
フィルターオプションで検索すればやり方はわかるでしょう
マクロよりは簡単です。
ただ、やり方によってはドツボにはまるので、
その時はここで、聞けばよいでしょう。
 
別に、フィルターオプションでなくてもいいと思いますが、並べ替え案はダメっぽいですか?

投稿日時: 18/07/17 10:29:08
投稿者: FILETUBE

皆さん、色々と本当にありがとうございます。
改めて内容を投稿します。
現状は下記の通りです。
 
条件1(B1セル 必須)
条件2(B2セル)
条件3(B3,B4,B5セル )
 
変更ボタンで8行目からを検索し
条件合致する行を塗りつぶしし
下に1行挿入し条件合致した行のKEY項目で
別のEXCELからデータを取得し行挿入した
行を埋める仕様となります。
 
For Each c In Range("A8:A100")
    ' 今回追加行は重複する為スキップ
    If c.Offset(0, 21).Value = 1 Then
        GoTo Continue
    End If
    ' 条件1(削除フラグ=9除く)
    If c.Offset(0, 21).Value = 9 Or c.Value <> Range("B1").Value Then
        GoTo Continue
    End If
    ' 名条件2
    If Range("B2").Value <> "" And c.Offset(0, 6).Value <> Range("B2").Value Then
        GoTo Continue
    End If
    ' 条件3
    If Range("B3").Value <> "" Or Range("B4").Value <> "" Or Range("B5").Value <> "" Then
       If c.Offset(0, 14).Value <> Range("B3").Value And _
          c.Offset(0, 14).Value <> Range("B4").Value And _
          c.Offset(0, 14).Value <> Range("B5").Value Then
          GoTo Continue
       End If
    End If
    '*** 条件合致処理 ***
    ' 行挿入
    Set rngNew = rngFind.Resize(1).Offset(c.Rows.Count)
    rngNew.Insert shift:=xlDown
    'データ取得
 
Continue:
    Next
 
行挿入した行にはc.Offset(0, 21).Value = 1とし
次のForではスキップするようにしました。
 
For Each c In Range("A8:A100")とA列にだけしました。
もう1点GoTo Continueは無くすようにしたいと思います。
 
フィルタオプションを使用した方が、処理効率が良いのかもしれないですが
大変申し訳ありません。

投稿日時: 18/07/26 17:51:08
投稿者: FILETUBE

多くの皆様ありがとうございました。
今後ともよろしくお願いします。