[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『帳票の日付が同じもの同士で重複をチェックしたいです。』（北のカエル）
Excelの表でB列に日付があり、同じ日付の範囲でF列、G列、J列、K列のそれぞれの列ごとで重複があればセルに色を付けて確認できるようにしたいです。上記の列のセルには改行された複数の文字列で記入してあり、1つでも重複したらセルに色を付けたいです。dictionaryオブジェクトを使用せず、できる方法があればお教えいただきたいです。よろしくお願いします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
１）サンプルデータの提示
２）dictionaryオブジェクトを使用したコードの提示
をお願いします。
（マナ） 2022/03/17(木) 18:31
１）Excelのサンプルは以下のとおりとなります。
Sheet1とSheet2で同じ書式として、違うシートの同じ日付、指定列で重複を確認したいです。
【Sheet1】
B列・・・F列・・・G列 J列 K列
4/1 A⇐色付
―――――――――――――――――――
4/1 A⇐色付き
B⇐色付き（Aが含まれるセルのため）
―――――――――――――――――――
4/1 C⇐色付き（Sheet2の4/1の範囲でCが含まれていると仮定してSheet2のCが含まれるセルも色付）
―――――――――――――――――――
4/5 A⇐色なし（日付が違うため色なし）
・
・
・ 以下 最終行まで
２）dictionaryオブジェクトを使用したコードを記載したことがなく、形になるようなコードができて
おりません。大変恐縮ですが、ヒントだけでもいただければ幸いです。
（北のカエル） 2022/03/17(木) 19:02
（マナ） 2022/03/17(木) 20:54
小学生が連立方程式を使わない方法でつるかめ算の解き方を教えてくださいって言ったら
ほんとに小学生か？って思うよね
（素朴な疑問） 2022/03/18(金) 06:35
仰る通りかもしれません。VBAに関して独学の初心者でして、作成したものを配布するとなったときにDictionaryオブジェクトを用いると個々の環境に依存して使用できないのではと考えたからでした。
ループで実現するとなると多重ループとなり、挙動が分からなくなってしまったため、ご質問した次第でした。
（北のカエル） 2022/03/18(金) 08:23
（わからん） 2022/03/18(金) 09:45
>多重ループとなり 別プロシジャに追い出しちゃいましょう
Sub sample()
Dim sRow As Long, numRow As Long
Dim rng As Range
sRow = 2
Do While IsDate(Cells(sRow, "B").Value)
numRow = 1
Do While Cells(sRow, "B").Value = Cells(sRow + numRow, "B").Value
numRow = numRow + 1
Loop
With Rows(sRow).Resize(numRow)
For Each strCol In Array("F", "G", "J", "K")
IndicateDupRow .Columns(strCol)
Next
End With
sRow = sRow + numRow
Loop
End Sub
Sub IndicateDupRow(rng As Range)
For i = 1 To rng.Rows.Count
For j = i + 1 To rng.Rows.Count
If checkContainSameValue(rng.Cells(i), rng.Cells(j).Value) Then
rng.Cells(i).Interior.ColorIndex = 6
rng.Cells(j).Interior.ColorIndex = 6
End If
Next
Next
End Sub
Function checkContainSameValue(a, b) As Boolean
checkContainSameValue = True
End Function
checkContainSameValueの中身はまたあとで。
（´・ω・`） 2022/03/18(金) 09:48
ご回答ありがとうございます。別のプロシージャに分けるという発想がなかなか思いつかず、どうしてもベタ打ちしてしまいますので、大変勉強になります。
引き続き、checkContainSameValueの方もお教えいただければ幸いです。よろしくお願いします。
（北のカエル） 2022/03/18(金) 10:26
悪いけどSheet1,Sheet2の部分は省略してる。
適当に改造してくれ。
Sub Macro()
Dim i As Long, j As Long
Dim s As String
Dim colArr(4) As Long
Dim m As Long, n As Long
colArr(0) = 6
colArr(1) = 7
colArr(2) = 10
colArr(3) = 11
For i = 1 To 5 - 1
For j = i + 1 To 5
If Cells(i, "B") = Cells(j, "B") Then
For m = 0 To 3
For n = 0 To 3
If InStr(CStr(Cells(i, colArr(n))), CStr(Cells(j, colArr(m)))) > 0 Then
Cells(i, "A").Interior.ColorIndex = 6
Cells(j, "A").Interior.ColorIndex = 6
ElseIf InStr(CStr(Cells(j, colArr(m))), CStr(Cells(i, colArr(n)))) > 0 Then
Cells(i, "A").Interior.ColorIndex = 6
Cells(j, "A").Interior.ColorIndex = 6
End If
Next n
Next m
End If
Next j
Next i
End Sub
（てらてら） 2022/03/18(金) 10:34
If InStr(CStr(Cells(i, colArr(n))), CStr(Cells(j, colArr(m)))) > 0 Then
Cells(i, colArr(n)).Interior.ColorIndex = 6
Cells(j, colArr(m)).Interior.ColorIndex = 6
ElseIf InStr(CStr(Cells(j, colArr(m))), CStr(Cells(i, colArr(n)))) > 0 Then
Cells(i, colArr(n)).Interior.ColorIndex = 6
Cells(j, colArr(m)).Interior.ColorIndex = 6
End If
（てらてら） 2022/03/18(金) 10:46
また、↓のように「セルには改行された複数の文字列」という条件が無くせるのであれば、既に提案されているようにCOUNTIFS関数をつかって【条件付き書式】で対応出来るでしょう。
__B__ ... __F__ __G__ ... __J__ __K__
1 日付 項目1 項目2 項目3 項目4
2 4/1 【あ】 か さ 【た】
3 4/1 【あ】 【き】 し 【た】
4 4/1 い 【き】 す 【た】
5 4/2 あ か さ た
6 4/2 い き し ち
7 4/3 あ か さ た
8 4/4 あ か さ た
データとしての活用もしやすくなると思うので、レイアウト修正が出来る段階なら検討してみては如何でしょうか？（日付の欄で同じ日付が並ぶのが嫌とかなら、2つめ以降の文字色を白にするだけで回避出来ます）
（もこな２ ） 2022/03/18(金) 11:32
私のは別シートのことを失念してましたので取り下げます。 ちょっと保留．． （´・ω・`） 2022/03/18(金) 12:32
（もこな２ ） さん
他の帳票からどうしても改行したデータが含まれるかたちで出力されてしまいます。
他のシートとも同時比較という点も難しいと感じています…
（´・ω・`）さん
もしよろしければ引き続き、アドバイスいただければ幸いです。
よろしくお願いします。
（北のカエル） 2022/03/18(金) 12:42
＞同じ日付の範囲でF列、G列、J列、K列のそれぞれの列ごとで重複があれば
＞違うシートの同じ日付、指定列で重複を確認
＞Sheet2の4/1の範囲でCが含まれていると仮定してSheet2のCが含まれるセルも色付
「列ごとで」というのが、他の条件と一致していないように思えます。
（わからん） 2022/03/18(金) 13:18
コードの提示も無いですし、何が分からない、苦労してるのか、 私には読み解けませんでした。 全部分からないっていう、ただの作成依頼でしょうか。
そうでない事を願って私見を。
セル内で改行しているなら、改行文字はLFなので、 Split関数で、その改行文字で分割すれば、文字列が取り出せます。 1次元配列またはCollectionを利用して、ユニークの文字列を抽出できるでしょう。 あとはベタにループすれば、重複確認は可能かと。
まず、ループが深くなっても、冗長的でもいいから、動くコードを書いてから、 別プロシージャにするなりして、スリムにしていけばいいんじゃないですか。 基礎的なロジックを構築できることが最優先ですよ。
（tkit） 2022/03/18(金) 13:37
説明が不得要領なので、確認します。 ●同一日付で複数行にわたることがあるんですか？それとも1日1行ですか？ セル内改行してまとめているということは、1日１行ではないんですか？
●(1)仮に1日１行だとして、 Sheet1のF1セルのセル内改行で分離した各文字列と比較すべきは、どのセルの文字列なんですか？ ・Sheet2のF1だけとも読めるし、（「列ごとで重複があれば」という日本語からはこう解釈される） ・Sheet1のG1,J1,K1 およびSheet2のF1,G1,J1,K1 とも読める。 (2)1日１行と限らなければ、B1と同一日付のものに広げて考えればよいのか。 肝心なことを明確に説明して欲しい。 （γ） 2022/03/19(土) 06:14
大作になってしまった．．． 解説はありません。 遅いです。 エラー処理が諸処必要と思うところありますが入れてません（くじけました） 質問者さんの意図とちがっていたら捨ててください。
Sub sample()
Dim target1 As Range, target2 As Range
Dim sRow As Long, d As Date
Dim tmpws As Worksheet, tmprng1 As Range, tmprng2 As Range
Application.ScreenUpdating = False
With ThisWorkbook
Set tmpws = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With
sRow = 2
Do While IsDate(Worksheets(1).Cells(sRow, "B").Value)
d = Worksheets(1).Cells(sRow, "B").Value
Set target1 = GetRangeByDate(Worksheets("Sheet1").Columns("B"), d)
Set target2 = GetRangeByDate(Worksheets("Sheet2").Columns("B"), d)
With CopyTarget(tmpws, target1, target2)
For Each strCol In Array("F", "G", "J", "K")
IndicateDupRow .Columns(strCol)
Next
End With
CopyFormat tmpws, target1, target2
sRow = sRow + target1.Rows.Count
Loop
Application.DisplayAlerts = False
tmpws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "終了"
End Sub
Private Function GetRangeByDate(rng As Range, d As Date) As Range
Dim sRow As Long, nRow As Long
On Error Resume Next
sRow = WorksheetFunction.Match(CLng(d), rng.Columns(1), 0)
If Err Then Exit Function
On Error GoTo 0
Do While d = rng.Columns(1).Cells(sRow + nRow)
nRow = nRow + 1
Loop
Set GetRangeByDate = rng.Rows(sRow).Resize(nRow)
End Function
Private Function CopyTarget(ws As Worksheet, ParamArray target()) As Range
Dim i As Long, r As Long, c As Range
r = 1
ws.Cells.Delete
For i = LBound(target) To UBound(target)
ws.Rows(r).Resize(target(i).Rows.Count).EntireRow.Value = target(i).EntireRow.Value
target(i).EntireRow.Copy
ws.Rows(r).Resize(target(i).Rows.Count).EntireRow.PasteSpecial xlPasteFormats
r = r + target(i).Rows.Count
Next
Set CopyTarget = ws.Rows(1).Resize(r - 1)
End Function
Private Sub CopyFormat(ws As Worksheet, ParamArray target())
Dim i As Long, r As Long, c As Range
r = 1
For i = LBound(target) To UBound(target)
ws.Rows(r).Resize(target(i).Rows.Count).EntireRow.Copy
target(i).EntireRow.PasteSpecial xlPasteFormats
r = r + target(i).Rows.Count
Next
End Sub
Private Sub IndicateDupRow(rng As Range)
For i = 1 To rng.Rows.Count
For j = i + 1 To rng.Rows.Count
If checkContainSameValue(rng.Cells(i), rng.Cells(j).Value) Then
rng.Cells(i).Interior.ColorIndex = 6
rng.Cells(j).Interior.ColorIndex = 6
End If
Next
Next
End Sub
Private Function checkContainSameValue(ByVal A As String, ByVal B As String) As Boolean
If A = "" Or B = "" Then Exit Function
If (UBound(Split(A, vbLf)) > UBound(Split(B, vbLf))) Then
tmp = A: A = B: B = tmp
End If
aryb = Split(B, vbLf)
For Each v In Split(A, vbLf)
On Error Resume Next
ret = 0
ret = WorksheetFunction.Match(v, aryb, 0)
On Error GoTo 0
If ret > 0 Then
checkContainSameValue = True
Exit Function
End If
Next
End Function
（´・ω・`） 2022/03/19(土) 08:20
Sub Test()
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
For Each ws In Array(ws1, ws2)
ws.Cells.Interior.Color = xlNone
For r = 1 To ws.Cells(Rows.Count, "B").End(xlUp).Row
If ws.Cells(r, "B") <> "" Then
For Each c In Array("F", "G", "J", "K")
buf = Split(ws.Cells(r, c), vbLf)
For i = LBound(buf) To UBound(buf)
n = 0
'For Each cc In Array("F", "G", "J", "K")
n = n + WorksheetFunction.CountIfs(ws1.Columns("B"), ws.Cells(r, "B"), ws1.Columns(cc), "*" & buf(i) & "*")
n = n + WorksheetFunction.CountIfs(ws2.Columns("B"), ws.Cells(r, "B"), ws2.Columns(cc), "*" & buf(i) & "*")
'Next
If n > 1 Then
ws.Cells(r, c).Interior.Color = vbRed
End If
Next
Next
End If
Next
Next
End Sub
（わからん） 2022/03/19(土) 13:29
"*" & buf(i) & "*" と COUNTIFS関数だと、部分一致になってしまうので注意が必要です。 （例："aa改行bb"に"a" がマッチ判定してしまうケース） 私もとあるところで InStrで判断するコードをそのまま追従してしまいましたが、これも間違いでした。 直さないといけないと思っていたところ、こちらの質問が出され修正する機会を逸していたところ、 （´・ω・`）さんからMatchを使う修正案が提示されました。 なお、私は、 tmp = Split(Cells(y, jj).Value, vbLf) If Not IsError(Application.Match(buf, tmp, 0)) Then のような On Error Resume Next を使わないコードにしていましたが。
（γ） 2022/03/19(土) 14:23
"*" & vbLf & buf(i) & vbLf & "*" buf(i) & vbLf & "*" "*" & vbLf & buf(i) buf(i)
（わからん） 2022/03/19(土) 14:40
（γ） 2022/03/19(土) 15:02
と同じかたですよね。 セル内改行で分離した文字列が同一なら色をつけるなどという特殊な話が、 同時期に別人から質問されるはずがありません。
少し待っていたのですが、反応が無いようなので（残念）、 書いておいてメモを投稿して私の区切りとします。
質問だけして、確認のためのコメントがあっても音沙汰なし というのはいかがなものですか？ しかも質問の当初では二つのシートなどと一言も言及がないのに、途中でころっと変わっています。 架空のケースで質問しているとさえ思えてしまいます。
(1) dictionaryを使わない理由が環境要因とのことですが、 scrrun.dllが無い mac環境なら分かりますが、WindowsならOSのバージョンに依らず普通に使えるはずです。 一般企業で、macとWindowsを混在して使用しているところは極めて稀だと思います。 また、実行時バインディングの書き方なので、参照設定も不要です。
(2) そもそもですが、各セルの文字列に対して、探索範囲で一致するかどうかを何度も何度も探索するのは無駄です。 特にこの場合、セル内改行で分離する処理が間に入るので、無駄感は半端ない。
分離後の各文字列がどのセルで登場したかを、 それらの文字列ごとにグルーピングすることは自然な発想です。
全体を一回調べるだけで済みます。 それができてしまえば、複数のセルに登場していたら、そのセルに色を付ければいいだけの話。 そして、そのことを簡単に実現できる「データ構造」がdictionaryということになります。 （文字列を指定するだけで、既存の情報があるかどうか、その値の保存場所等を検索するのは、 極めて高速です。Hash Tableという仕組みを内部に持っているからだそうです。）
(3) Dictionaryは、連想配列とかHashとかmapとかobjectとかHashmapとか色々な呼び方がありますが、 たいていのプログラム言語には必ず備わっている、配列と並ぶ代表的なデータ構造です。 要件にあった適切なデータ構造を使うのはあたりまえで、 これを使わないほうが不自然とさえいえるほどのものです。 優越感がどうこうといったろくでもない話じゃないのです。
既に前回のスレッドでdictionaryを使ったコードを提示しています。 それはさほど複雑ではないので若干の慣れで普通に理解できると思われます。
(4) 仕様は確定的ではないが、参考までに今回の件をコードで書くとこんな風に書けます。（末尾参照） 実行時間は、 （´・ω・`）さんが速度について触れられています。制約下の工夫でしょう。 dictionaryを使うと格段に速くなりますね。 テストしたところ、dictionaryを利用すると、それの 2%くらいの時間で済んでしまいます。 （30行くらいのテストデータで2秒に対して、0.04秒くらいです。 もちろん2秒でも十分早いという見方もあります。何を急いでいるんだと。）
入れ子にした階層構造にしている点は少し理解しにくいかもしれません。 しかし、こういう設定の課題には、こうした考え方も十分ありうると考えます。 参考コードは以下です。仕様が異なれば捨ててください。
Option Explicit
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dic As Object
Sub main()
Dim k As Long
Dim vB, col
Dim vcol As String
Dim ary, a, ws
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
ws1.Range("F1,G1,J1,K1").EntireColumn.Interior.ColorIndex = xlNone
ws2.Range("F1,G1,J1,K1").EntireColumn.Interior.ColorIndex = xlNone
'key:セル内改行で分離した文字列 → item:そのアドレス の辞書を
'日付別、列別（ただしシート横断）に作成する。(辞書の入れ子にしてある。)
For Each ws In Array(ws1, ws2)
For k = 2 To ws.Cells(Rows.Count, "B").End(xlUp).Row
vB = ws.Cells(k, "B").Value '日付
If Not dic.exists(vB) Then Set dic(vB) = CreateObject("Scripting.Dictionary")
For Each col In Array("F", "G", "J", "K")
vcol = ws.Cells(k, col)
If vcol <> "" Then
If Not dic(vB).exists(col) Then Set dic(vB)(col) = CreateObject("Scripting.Dictionary")
ary = Split(vcol, vbLf)
For Each a In ary
dic(vB)(col)(a) = dic(vB)(col)(a) _
& ws.Name & "!" & ws.Cells(k, col).Address(False, False) & ","
'Debug.Print vB, col, a, dic(vB)(col)(a)
Next
End If
Next
Next
Next
'文字重複を判定して、重複していた場合はその文字列のあるセルに色をつける
Dim e1, e2, e3
Dim adrses
For Each e1 In dic.keys
For Each e2 In dic(e1).keys
For Each e3 In dic(e1)(e2).keys
adrses = Split(dic(e1)(e2)(e3), ",")
If UBound(adrses) > 1 Then
For k = 0 To UBound(adrses) - 1
Range(adrses(k)).Interior.ColorIndex = 6
Next
End If
Next
Next
Next
Application.ScreenUpdating = True
End Sub
（γ） 2022/03/23(水) 11:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.