[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『リストにある2列ずつのデータが 不一致の物を探したい』(ゆう)
投稿
[[20101113104924]] 『2列ずつのデータが一致した場合に色をつける』(キム)
について...
過去の質問を検索させて頂いている中で、上記内容が近いと思ったのですが・・・色々探してみたのですが、自分の知識では解決できませんでした。
以下がレイアウトです
シート1
| A | B | C | D | E | F |・・ 01 | A | あ | A い ←質問2のみエラー 02 | B | い | A あ 03 | C | う | う ←質問1、2ともにエラーではない 04 | D | え | Z ←質問1、2ともにエラー 05 | E | お | B う ←質問2のみエラー 06 | F | か | ←質問1、2ともエラーではない
シート2
| A | B | 01 | A | あ | 02 | B | い | 03 | C | う | 04 | D | え | 05 | E | お | 06 | F | か |
2点行いたいことがあるのですが、ご教授お願いします。
1点目は、シート2のA列の中にある文字列(1000行くらい)以外が、
シート1の奇数列(A,C、E、・・・・)にあれば、シート1の該当するセルのみの背景色を茶色にしたい。ただし、シート1の奇数列が空白の場合は、処理しない。
2点目は、シート2のA列とB列の中にある文字列がA1= B1,A2=B2、C3=D3、…のように、2列のセットで不一致の文字列が、
シート1にあればその該当する二つのセルにのみ、背景色を青色にしたい。ただし、シート1の二つのセルともに空白の場合は、処理しない。片方だけ文字列があった場合には二つのセルとも背景色を青色にしたい。
どうかよろしくお願いします。
< 使用 Excel:Excel2010、使用 OS:WindowsXP >
| A | B | C | D | E | F |・・ 03 | C | う | う ←質問1、2ともにエラーではない →上記の箇所の質問1,2ともにエラーではない。 →正しくは質問1はエラーではない。質問2はエラーです (ゆう) 2017/08/11(金) 09:11
A1からデータが始まる場合を想定しています。 A1以外から(B2等)からデータが始まる場合は、別途調整が必要です。
条件についてですが、提示の例だと、茶色になるところありませんよね? C4:D4は条件2が優先されるので、茶色→青に塗り替えで合っていますか?
Option Explicit
Sub test() Dim vData As Variant Dim vList As Variant vData = Sheets("Sheet1").Range("A1").CurrentRegion.Value '★ vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★
'[必須]参照設定 MicrosoftScriptingRuntime Dim dic(1) As Dictionary Set dic(0) = New Dictionary Set dic(1) = New Dictionary
Dim ir As Long For ir = 1 To UBound(vList, 1) dic(0)(vList(ir, 1)) = "" dic(1)(vList(ir, 1) & vList(ir, 2)) = "" Next ir
Dim ic As Long Dim rColor(1) As Range Dim ID As String For ic = 1 To UBound(vData, 2) Step 2 '奇数 For ir = 1 To UBound(vData, 1) '//条件1 ID = vData(ir, ic) If ID <> "" And Not dic(0).Exists(ID) Then Set rColor(0) = SetColorRange(rColor(0), Sheets("sheet1").Cells(ir, ic)) '★ End If
'//条件2 ID = vData(ir, ic) & vData(ir, ic + 1) If ID <> "" And Not dic(1).Exists(ID) Then Set rColor(1) = SetColorRange(rColor(1), Sheets("sheet1").Range(Cells(ir, ic), Cells(ir, ic + 1))) '★ End If Next ir Next ic Sheets("Sheet1").Cells.Interior.ColorIndex = xlNone If Not rColor(0) Is Nothing Then rColor(0).Interior.Color = RGB(153, 51, 0) '茶色 End If If Not rColor(1) Is Nothing Then rColor(1).Interior.Color = vbBlue End If Set dic(0) = Nothing Set dic(1) = Nothing Set rColor(0) = Nothing Set rColor(1) = Nothing End Sub
Function SetColorRange(ByVal rng As Range, ByVal Inputrng As Range) As Range If rng Is Nothing Then Set SetColorRange = Inputrng Else Set SetColorRange = Union(rng, Inputrng) End If End Function (稲葉) 2017/08/11(金) 10:19
条件2 C4:D4は条件2が優先されるので、茶色→青に塗り替えで合っていますか?
あっ!!条件2が優先であれば、確かに、茶色になるところありません。あっています。
すみませんでした。私の想定ミスです。条件2だけで問題ないです。
(ゆう) 2017/08/11(金) 10:45
・・・ですよね。 条件1が成立する場合、条件2は必ず成立ですもんね。
いかに差し替えでお願いします。 Option Explicit
Sub test() Dim wsData As Worksheet Set wsData = Sheets("Sheet1") '★
Dim vData As Variant Dim vList As Variant vData = wsData.Range("A1").CurrentRegion.Value '★ vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★
'[必須]参照設定 MicrosoftScriptingRuntime Dim dic As Dictionary Set dic = New Dictionary
'//辞書の作成 Aあ Bい・・・ Dim ir As Long For ir = 1 To UBound(vList, 1) dic(vList(ir, 1) & vList(ir, 2)) = "" Next ir
Dim ic As Long Dim rColor As Range Dim ID As String For ic = 1 To UBound(vData, 2) Step 2 '奇数列 For ir = 1 To UBound(vData, 1) '//条件2 ID = vData(ir, ic) & vData(ir, ic + 1) 'ここでインデックスエラーが出たら、表の範囲外に何らかの入力がある If ID <> "" And Not dic.Exists(ID) Then If rColor Is Nothing Then Set rColor = wsData.Range(Cells(ir, ic), Cells(ir, ic + 1)) Else Set rColor = Union(rColor, wsData.Range(Cells(ir, ic), Cells(ir, ic + 1))) End If End If Next ir Next ic wsData.Cells.Interior.ColorIndex = xlNone If Not rColor Is Nothing Then rColor.Interior.Color = vbBlue Set dic = Nothing Set rColor = Nothing End Sub (稲葉) 2017/08/11(金) 11:13
しかしながら、実物で動かしたい表が少し違いまして・・・本当にすみません。
調べながら別途調整をしていましたが、どうも上手くいかなくて困っています。
実物のシート1のレイアウトは
D5:FI35の範囲の中で 、質問と同様にシート2のA1 =B1・・・と続く中の、一致しないものを探したいです。
シート1
| A | B | C | D| E | | F |G|・・・ 01 | | | | | | 02 | | | | | | 03 | | | | | | 04 | | | |セル結合 |セル結合 と同様に続いています 05 | | |関数 |A |あ |B|あ| 06 | | |関数 |C |う |D|う|
Sheets("Sheet2").Range("A1").CurrentRegion.Value
上記にて取得する表の範囲は流動的ですが うまく取得できています。
vData = wsData.Range("A1").CurrentRegion.Value
A1からC4に変更したら、A1:FI36の表範囲を取得していました。
エラー箇所は、ID = vData(ir, ic) & vData(ir, ic + 1) '
ここでインデックスエラーが出たら、表の範囲外に何らかの入力があるとのことでしたが、調整が出来なくて情けない。
D5を起点のセル、終点をFG35にとも考えたのですが、どうも修正がうまくいかないです。
(ゆう) 2017/08/11(金) 20:34
>D5を起点のセル、終点をFG35にとも考えたのですが、どうも修正がうまくいかないです。 実際の表は2セット4列だけなんですか? 最終行と最終列が固定であればいいんですが、そうでない場合行・列の最終行を取得する必要があります。
どのようなデータかわかりませんので、手が出せません。
もう少し詳しく説明いただけますか? (稲葉) 2017/08/11(金) 22:13
DE EF GH HI JK LM OP QR ST UV WX YZ AA,AB BC,CD ・・・ FF,FG 5 6 7 8 9
シート2のA列、B列に関しては、200行程度で順次増えていきます。
(ゆう) 2017/08/11(金) 22:46
変更点数か所なのですが、1から書き直さないと非常にわかりにくいコードですね・・・ 急ぎなら下記コード、そうでなければ、時間があるときに書き直します。 なんかバグありそう
Option Explicit
Sub test() Dim wsData As Worksheet Set wsData = Sheets("Sheet1") '★ Dim rngData As Range Set rngData = wsData.Range("D5:FG35") Dim vData As Variant Dim vList As Variant vData = rngData.Value vList = Sheets("Sheet2").Range("A1").CurrentRegion.Value '★ '[必須]参照設定 MicrosoftScriptingRuntime Dim dic As Dictionary Set dic = New Dictionary '//辞書の作成 Aあ Bい・・・ Dim ir As Long For ir = 1 To UBound(vList, 1) dic(vList(ir, 1) & vList(ir, 2)) = "" Next ir Dim ic As Long Dim rColor As Range Dim ID As String For ic = 1 To UBound(vData, 2) Step 2 '奇数列 For ir = 1 To UBound(vData, 1) '//条件2 ID = vData(ir, ic) & vData(ir, ic + 1) 'ここでインデックスエラーが出たら、表の範囲外に何らかの入力がある If ID <> "" And Not dic.Exists(ID) Then If rColor Is Nothing Then Set rColor = rngData.Range(Cells(ir, ic), Cells(ir, ic + 1)) Else Set rColor = Union(rColor, rngData.Range(Cells(ir, ic), Cells(ir, ic + 1))) End If End If Next ir Next ic wsData.Cells.Interior.ColorIndex = xlNone If Not rColor Is Nothing Then rColor.Interior.Color = vbBlue Set dic = Nothing Set rColor = Nothing End Sub (稲葉) 2017/08/11(金) 22:56
そういう情報は最初に・・・ これに限ったことではないのですが、何かを変更する場合は、初期値にしてから実行するので 現状を変えてほしくないのであればそう書いてくれると助かります。
解決策は wsData.Cells.Interior.ColorIndex = xlNone をコメントアウトするだけです。 (稲葉) 2017/08/11(金) 23:18
C D E F ああああ いいい 4 A あ A い 5 B い A あ 6 C う う 7 D え Z 8 E お B う 9 F か
Sheet2>>
A B 1 項目1 項目2 2 A あ 3 B い 4 C う 5 D え 6 E お 7 F か
Sheet3>>
A B 1 項目1 項目2 2 <> <>
以上のようなシートとして以下のコードでいかがでしょう?
Sub test()
Dim rngTable As Range '加工したい表のセル範囲(固定) Dim rngList As Range '検索するキーワード一覧のセル範囲(可変) Dim rngException As Range '例外の条件(公開は空白)のセル範囲 Dim rngWork As Range '作業用のセル範囲 Dim i As Long '列のインデックス番号
Set rngTable = Worksheets("Sheet1").Range("C4:F9") Set rngList = Worksheets("Sheet2").Range("A1").CurrentRegion Set rngException = Worksheets("Sheet3").Range("A1").CurrentRegion
For i = 1 To rngTable.Columns.Count Step 2 Set rngWork = rngList.Offset(rngList.Rows.Count + 1) rngTable.Columns(i).Resize(, 2).Copy rngWork
With rngWork.CurrentRegion Application.Range(rngList, .Cells).AdvancedFilter _ Action:=xlFilterInPlace, _ CriteriaRange:=rngException, _ Unique:=True
On Error Resume Next .SpecialCells(xlCellTypeVisible).Interior.Color = vbBlue On Error GoTo 0 .Parent.ShowAllData .Copy rngTable(1, i) .Delete Shift:=xlToLeft End With Next End Sub
シート1のセル範囲は固定なのですね?
直せますかね?
って、すでに解決済みだったのかな。。。orz
わかりにくい。。。。
(まっつわん) 2017/08/12(土) 21:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.