[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルの色毎に一覧に出力する』（中也さん）
こんにちは。
セルの色を判別してデータを出力したいのですが教えて下さい。
「結果」シートのマクロボタン実行で「期限一覧」シートの赤色RGB(255, 0, 0)と黄色RGB(255, 255, 0)のセルを検索し、「結果」シートに順番に出力したいです。
「期限一覧」シートには他の色のセルもありますがスルーしたいです。
※検索範囲はC2セル〜E5セル
※出力結果は「PC名」空白「SW名」空白「日付」の1行にまとめたい
※できるだけ、ForとIfを使いたいです
因みに赤は期限切れ、黄色は1年後に切れるです。
■「期限一覧」シート
A列 B列 C列 D列 E列
1行目 SW名 日付 PC1 PC2 PC3
2行目 Office 12/1
3行目 サクラ 1/1 赤 赤
4行目 IE 2/1 黄 黄
5行目 捺印 3/1 赤 赤
■「結果」シート（出力結果）
「A1」セルから順に赤色セルの情報を。
PC1 サクラ 1/1
PC2 サクラ 1/1
PC1 捺印 3/1
「B1」セルから順に黄色セルの情報を。
PC1 IE 2/1
PC2 IE 2/1
お手数お掛けしますが、ご教授の程お願いします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
（もこな２） 2021/12/09(木) 16:57
横から失礼します。
特定の色に関しては、定数を使うこともできます。
https://katakago.sakura.ne.jp/pgm/vba/pgm01/vbcolor.html
参考まで。 （通りすがり） 2021/12/09(木) 17:33
Sub 研究用()
Dim 赤出力 As Range, 黄出力 As Range
Dim MyRNG As Range
Stop
With Worksheets("結果")
Set 赤出力 = .Range("A1")
Set 黄出力 = .Range("B1")
End With
With Worksheets("期限一覧")
For Each MyRNG In .Range("C2:E5")
If MyRNG.Interior.Color = RGB(255, 0, 0) Then
赤出力.Value = .Cells(1, MyRNG.Column).Value & " " & .Cells(MyRNG.Row, 1).Value & " " & Format(.Cells(MyRNG.Row, 2).Value, "m/d")
Set 赤出力 = 赤出力.Offset(1)
ElseIf MyRNG.Interior.Color = RGB(255, 255, 0) Then
黄出力.Value = .Cells(1, MyRNG.Column).Value & " " & .Cells(MyRNG.Row, 1).Value & " " & Format(.Cells(MyRNG.Row, 2).Value, "m/d")
Set 黄出力 = 黄出力.Offset(1)
End If
Next
End With
End Sub
※↑は少々冗長な気もしますし、現状のコードを示して頂いたほうが具体的なアドバイスが受けられると思います。
（もこな２） 2021/12/09(木) 18:48
For i = 2 To 5
If Sh1.Cells(i, j).Interior.Color = RGB(255, 0, 0) Then
Sh1.Cells(i, j).Copy Sh2.Cells(Q, 1)
と分かりにくかったので大変助かりました。
また出力の箇所を見やすいよう少し追加しました。
修正前）
赤出力.Value = .Cells(1, MyRNG.Column).Value & " " & .Cells(MyRNG.Row, 1).Value & " " & Format(.Cells(MyRNG.Row, 2).Value, "m/d")
修正後）
赤出力.Value = "【" &.Cells(1, MyRNG.Column).Value & "】" & " " & .Cells(MyRNG.Row, 1).Value & " " & Format(.Cells(MyRNG.Row, 2).Value , "＜" & "yyyy/m/d") & "＞"
■出力結果
【PC1】 サクラ ＜2021/1/1＞
■追加でこちらの問題が起きたのですが、少し自分で調べてみます。
セルの色付けを「条件付き書式」で設定しているのですが、自動で色付けされた箇所を「セルの書式設定」で覗くと
塗り潰しが指定なしになっています。
そのため、今回のマクロでセルの色が認識されませんでした。
どうやらフィルターを掛けると認識されるので、マクロで色を上書きしようと思います。
＜手順＞フィルターをかける⇒色でくくる⇒色を上書きする
できそうになかったら改めて新規で質問させて頂こうと思います。
宜しくお願いします。
（中也さん） 2021/12/10(金) 15:54
■２
＞セルの色付けを「条件付き書式」で設定しているのですが
γさんがコメントされているとおり。
■３
＞この投票を載せたあとも色々調べて、?@最初のC2セル〜E5セルを順番に見るマクロからとりかかったのですが
よくわかりませんが、"質問"されたときは何も手を付けてなかったということですか？
単に発注したいだけならその旨始めから表明しておいてほしいです。（そういったことには興味ないため関わりたくないので）
そうでなくて、ちゃんと質問だったということであれば、再三になりますがコードを提示してどのように困っているのか（エラーが発生するならその個所、エラー番号、エラーメッセージの提示、エラーにならないが想定外の動きになるなら××になるはずが○○になる等）説明いただくとアドバイスできることがあるかもしれません。
■４
上記にかぶりますがどうも作成依頼だったような気もするので"質問"があるまでしばしROMりますが、書いてしまったので研究材料として投稿しておきます。
あえてステップ実行してみないと理解しにくいように雑な書き方にしています。 この記述方法を推奨しているという意味ではありませんので誤解の無いように願います。
Sub 研究用2()
Dim 行 As Long, 列 As Long, 出力列 As Long
Stop 'ブレークポイントの代わり
With Worksheets("期限一覧")
For 列 = 3 To 5: For 行 = 2 To 5
Select Case .Cells(行, 列).DisplayFormat.Interior.Color
Case RGB(255, 0, 0): 出力列 = 1
Case RGB(255, 255, 0): 出力列 = 2
Case Else: 出力列 = 0
End Select
If 出力列 > 0 Then Worksheets("結果").Cells(Rows.Count, 出力列).End(xlUp).Offset(1).Value = _
"【" & .Cells(1, 列).Value & "】" & " " & .Cells(行, 1).Value & " " & Format(.Cells(行, 2).Value, "＜" & "yyyy/m/d") & "＞"
Next 行: Next 列
End With
If WorksheetFunction.CountA(Worksheets("結果").Rows(1)) = 0 Then Worksheets("結果").Rows(1).Delete
End Sub
（もこな２） 2021/12/10(金) 20:00
すいません。
以前小出しで質問した際にやりたい事が分かりにくいと言われたので、今回は全部書いてしまいました。
指定の範囲内の検索方法とヒットしたセルのSW名と機器名を読み取る方法で苦戦し、質問させて頂きました。
頂いたコード、検索範囲の指定が簡潔でとてもわかり易かったです。
ありがとうございました。
（中也さん） 2021/12/14(火) 11:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.