[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『列で一致した場合は書き出す』（フレミング）
以下のようなVBAを考えてみましたが
サンプルでB,C列に同じ文字列を書き込んでチェックしても
何もマッチしないのか？E、F列に何も表示されません。
どこか考え違いがありますか ？
（ループする個数は、C列が一番数が大きのでCの列数で調べるようにしています。）
Option Explicit
'A列､B列､C列の各セルの文字列を比較し､
'一致する場合にE列に該当する文字列､F列に列名を記載する
'
'"C"列全てが一致する場合は "A, B, C"、
'"B"列が一致する場合は、"A, B"、"A, C"、"B, C" と記載する。
'
Sub CompareColumns()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
For i = 2 To lastRow
If ws.Cells(i, "A").Value = ws.Cells(i, "B").Value And ws.Cells(i, "A").Value = ws.Cells(i, "C").Value Then
ws.Cells(i, "E").Value = ws.Cells(i, "A").Value
ws.Cells(i, "F").Value = "A, B, C"
ElseIf ws.Cells(i, "A").Value = ws.Cells(i, "B").Value Then
ws.Cells(i, "E").Value = ws.Cells(i, "A").Value
ws.Cells(i, "F").Value = "A, B"
ElseIf ws.Cells(i, "A").Value = ws.Cells(i, "C").Value Then
ws.Cells(i, "E").Value = ws.Cells(i, "A").Value
ws.Cells(i, "F").Value = "A, C"
ElseIf ws.Cells(i, "B").Value = ws.Cells(i, "C").Value Then
ws.Cells(i, "E").Value = ws.Cells(i, "B").Value
ws.Cells(i, "F").Value = "B, C"
End If
Next i
MsgBox "処理が終了しました。"
End Sub
＜ 使用 Excel：unknown、使用 OS：Windows11 ＞
（ベタベタ） 2024/11/21(木) 14:49:03
（ベタベタ） 2024/11/21(木) 14:54:05
（ベタベタ） 2024/11/21(木) 14:55:38
「普通に動きますけど」を無視するのですか？
それとも「Exit For した方がいいかも。」を無視するのですか？
現状のコードの場合
B列14行目のセルとC列の13行目のセルが同じ文字列の場合、
結果は、E1にB14の文字列、F1にB,Cと表示されるはずですが
E列の行には何も文字列が記入されずに
F列の40行目から57行目までにA,Bと記載されてしまします。
（フレミング） 2024/11/21(木) 15:19:20
あと、1回きりの処理ですか?
繰り返し使うなら最初にE列とF列の値を消す処理が必要かと
（abec） 2024/11/21(木) 15:36:17
やりたいことは、
B列14行目のセルとC列の13行目のセルが同じ文字列の場合、
E1にB14の文字列、F1にB,Cと表示したい
コードを変更してみましたがE１に何も表示されずに
F2からF20までにA,Bと表示されてしまいます。
Option Explicit
'A列､B列､C列の各セルの文字列を比較し､
'一致する場合にE列に該当する文字列､F列に列名を記載する
'
'"C"列全てが一致する場合は "A, B, C"、
'"B"列が一致する場合は、"A, B"、"A, C"、"B, C" と記載する。
'
Sub CompareColumns()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim j As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
ws.Range("E:F").ClearContents
j = 2
For i = 2 To lastRow
If ws.Cells(i, "A").Value = ws.Cells(i, "B").Value And ws.Cells(i, "A").Value = ws.Cells(i, "C").Value Then
ws.Cells(j, "E").Value = ws.Cells(i, "A").Value
ws.Cells(j, "F").Value = "A, B, C"
j = j + 1
ElseIf ws.Cells(i, "A").Value = ws.Cells(i, "B").Value Then
ws.Cells(j, "E").Value = ws.Cells(i, "A").Value
ws.Cells(j, "F").Value = "A, B"
j = j + 1
ElseIf ws.Cells(i, "A").Value = ws.Cells(i, "C").Value Then
ws.Cells(j, "E").Value = ws.Cells(i, "A").Value
ws.Cells(j, "F").Value = "A, C"
j = j + 1
ElseIf ws.Cells(i, "B").Value = ws.Cells(i, "C").Value Then
ws.Cells(j, "E").Value = ws.Cells(i, "B").Value
ws.Cells(j, "F").Value = "B, C"
j = j + 1
End If
Next i
MsgBox "処理が終了しました。"
End Sub
（フレミング） 2024/11/21(木) 15:45:13
Worksheets("G_H_Drive")の想像図 ← あくまで私の想像の範囲を出ません
このような感じで、当該シートのマクロ実行の前後
をご説明されては如何でしょうか。^^;。。。m(__)m
|[A] |[B] |[C] |[D]|[E] |[F]
[1] |F1 |F2 |F3 | |Excel|A,B,C
[2] |A2 |B2 |C2 | |X |C,B
[3] |EXCEL|B3 |C3 | | |
[4] |A4 |EXCEL|C4 | | |
[5] |A5 |B5 |EXCEL| | |
[6] |A6 |B6 |C6 | | |
[7] |A7 |B7 |C7 | | |
[8] |A8 |B8 |C8 | | |
[9] |A9 |B9 |C9 | | |
[10]|A10 |B10 |C10 | | |
[11]|A11 |B11 |C11 | | |
[12]|A12 |B12 |C12 | | |
[13]|A13 |B13 |C13 | | |
[14]|A14 |B14 |X | | |
[15]|A15 |X |C15 | | |
[16]|A16 |B16 |C16 | | |
[17]| | | | | |
↑でよければ、今少し、工夫が必要かもしれませんですね。
↓ 便利ですよ (*^^*) でわ
' 投稿用シートレイアウトをクリップボードに取得
' 作成者（ｍｏｍｏ）
'
' BrkStr：列間の文字列 初期値は「|」
' DataObjectID：DataObjectのLate Binding用（変更不可）
' http://www.excel.studio-kazu.jp/kw/20110209184943.html
（隠居Z） 2024/11/21(木) 15:55:06
まさにこのような図の結果になりたいのです。
よくよく考えると各セルの文字列ごとに
他の列のセル一つ一つと同じかチェックしないとだめなので
私が示したコードでは不十分だと理解しました。
もう少し工夫してみます。
（フレミング） 2024/11/21(木) 16:06:46
Sub test()
Dim dicA As Object, dicB As Object, dicC As Object
Set dicA = CreateObject("Scripting.Dictionary")
Set dicB = CreateObject("Scripting.Dictionary")
Set dicC = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
.Range("E:F").ClearContents
Dim i As Long
For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
If .Cells(i, "A").Value <> "" And Not dicA.Exists(.Cells(i, "A").Value) Then dicA.Add .Cells(i, "A").Value, ""
If .Cells(i, "B").Value <> "" And Not dicB.Exists(.Cells(i, "B").Value) Then dicB.Add .Cells(i, "B").Value, ""
If .Cells(i, "C").Value <> "" And Not dicC.Exists(.Cells(i, "C").Value) Then dicC.Add .Cells(i, "C").Value, ""
Next i
Dim r As Long, Key As Variant
r = 2
For Each Key In dicA.Keys
If dicB.Exists(Key) And dicC.Exists(Key) Then
.Cells(r, "E").Value = Key
.Cells(r, "F").Value = "A,B,C"
dicB.Remove (Key)
dicC.Remove (Key)
r = r + 1
ElseIf dicB.Exists(Key) Then
.Cells(r, "E").Value = Key
.Cells(r, "F").Value = "A,B"
dicB.Remove (Key)
r = r + 1
ElseIf dicC.Exists(Key) Then
.Cells(r, "E").Value = Key
.Cells(r, "F").Value = "A,C"
dicC.Remove (Key)
r = r + 1
End If
Next Key
For Each Key In dicB.Keys
If dicC.Exists(Key) Then
.Cells(r, "E").Value = Key
.Cells(r, "F").Value = "B,C"
r = r + 1
End If
Next Key
End With
End Sub
（む） 2024/11/21(木) 16:35:37
いただいたコードで完璧に結果が出ました。
CreateObject("Scripting.Dictionary")なるしらないコードが出てきたので
調べてみます。
ところで
自分なりにコードを見直して取り敢えず２つが同じ場合は以下のVBAで良いと思うのですが？
どうでしょうか ？
３つが同じ場合を同じ思考で考えてみましたが
ループのループでぐちゃぐちゃになりコードが作れていません。
以下のコードを活かすとすればどのようなコードになりますか？
むさんのコードが示された後ですが取り得ず自分なりのVBAを完成したいので
教えてもらえると理解が深まると思いますのでお願いします。
Option Explicit
'A列､B列､C列の各セルの文字列を比較し､
'一致する場合にE列に該当する文字列､F列に列名を記載する
'
'3列全てが一致する場合は "A, B, C"、
'2列が一致する場合は、"A, B"、"A, C"、"B, C" と記載する。
'
Sub CompareColumns()
Dim ws As Worksheet
Dim lastRowA As Long, lastRowB As Long, lastRowC As Long
Dim i As Long, j As Long
Dim k As Long, l As Long, m As Long, n As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
lastRowC = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
ws.Range("E:F").ClearContents
j = 2
For i = 2 To lastRowA
'A列とB列が一致する場合は、"A,B"
For k = 2 To lastRowB
If ws.Cells(i, "A") = ws.Cells(k, "B") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "A,B"
j = j + 1
End If
Next k
'A列とC列が一致する場合は、"A,C"
For l = 2 To lastRowC
If ws.Cells(i, "A") = ws.Cells(l, "C") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "A,C"
j = j + 1
End If
Next l
Next i
'B列とC列が一致する場合は、"B,C"
For m = 2 To lastRowB
For n = 2 To lastRowC
If ws.Cells(m, "B") = ws.Cells(n, "C") Then
ws.Cells(j, "E") = ws.Cells(m, "B")
ws.Cells(j, "F") = "B,C"
j = j + 1
End If
Next n
Next m
MsgBox "処理が終了しました。"
End Sub
（フレミング） 2024/11/21(木) 17:05:27
どこが一致しているか同時に表示するようにコードを変えました。
こちらで回答いただければ嬉しいです。
Option Explicit
'A列､B列､C列の各セルの文字列を比較し､
'一致する場合にE列に該当する文字列､F列に列名を記載する
'
'3列全てが一致する場合は "A, B, C"、
'2列が一致する場合は、"A, B"、"A, C"、"B, C" と記載する。
'
Sub CompareColumns()
Dim ws As Worksheet
Dim lastRowA As Long, lastRowB As Long, lastRowC As Long
Dim i As Long, j As Long
Dim k As Long, l As Long, m As Long, n As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
lastRowC = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
ws.Range("E:F").ClearContents
j = 2
For i = 2 To lastRowA
'A列とB列が一致する場合は、"A,B"
For k = 2 To lastRowB
If ws.Cells(i, "A") = ws.Cells(k, "B") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "A" & i & ", B" & k
j = j + 1
End If
Next k
'A列とC列が一致する場合は、"A,C"
For l = 2 To lastRowC
If ws.Cells(i, "A") = ws.Cells(l, "C") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "A" & i & ", C" & l
j = j + 1
End If
Next l
Next i
'B列とC列が一致する場合は、"B,C"
For m = 2 To lastRowB
For n = 2 To lastRowC
If ws.Cells(m, "B") = ws.Cells(n, "C") Then
ws.Cells(j, "E") = ws.Cells(m, "B")
ws.Cells(j, "F") = "B" & m & ", C" & n
j = j + 1
End If
Next n
Next m
MsgBox "処理が終了しました。"
End Sub
（フレミング） 2024/11/21(木) 17:15:35
その後、何とか以下のようのコードにすれば
３つの列が同じ場合も表示されるようになりますが
現在のコードでは３つの内２つが同じかをチェックコードも続けて行うので
結果としてA-B-C,A-B,B-C,A-Cと４行表示される事になります。
実際は、A-B-Cの１行で良いので３つが同じ場合は
３つの内２つが同じかをチェックコードを飛ばすようにするには
どこにgoto文を入れて処理すれば良いですか？
ｊ＝２をフラグとしてif文で処理出来そうなのですがここでツマズイています。
コード自体に不合理があれば含めてご指導ください。
Sub 重複_2()
Dim ws As Worksheet
Dim lastRowA As Long, lastRowB As Long, lastRowC As Long
Dim i As Long, j As Long
Dim k As Long, l As Long, m As Long, n As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
lastRowC = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
ws.Range("E:F").ClearContents
ws.Range("E1") = "重複名"
ws.Range("F1") = "重複ドライブ"
j = 2
For i = 2 To lastRowA
' A列、B列、C列が全て一致する場合
For k = 2 To lastRowB
For l = 2 To lastRowC
If ws.Cells(i, "A") = ws.Cells(k, "B") And ws.Cells(i, "A") = ws.Cells(l, "C") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "H:" & i & ", G:" & k & ", D:" & l
j = j + 1
End If
Next l
Next k
'A列とB列が一致する場合
For k = 2 To lastRowB
If ws.Cells(i, "A") = ws.Cells(k, "B") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "H:" & i & ", G:" & k
j = j + 1
End If
Next k
'A列とC列が一致する場合
For l = 2 To lastRowC
If ws.Cells(i, "A") = ws.Cells(l, "C") Then
ws.Cells(j, "E") = ws.Cells(i, "A")
ws.Cells(j, "F") = "H:" & i & ", D:" & l
j = j + 1
End If
Next l
Next i
'B列とC列が一致する場合
For m = 2 To lastRowB
For n = 2 To lastRowC
If ws.Cells(m, "B") = ws.Cells(n, "C") Then
ws.Cells(j, "E") = ws.Cells(m, "B")
ws.Cells(j, "F") = "G:" & m & ", D: " & n
j = j + 1
End If
Next n
Next m
End Sub
（フレミング） 2024/11/21(木) 19:14:28
１． 検索範囲の一意なキーを作成
２． １．を基に重複するキーだけを取得 ← このとき連想配列がとても役に立ちます^^;
３． ２．を基準に全範囲をループして重複する場合に必要な情報を取得して何かに格納
４． ３．で格納したものを所定の場所に書き出す
あと、エクセルのバージョンを教えて戴くと、３６５等でしたら、窓口がとても広くなります
Dictinaryを使わなくても。Uniqu CounfIF とかでも使えると代替出来るかもしれません。
以下は上をふまえた研究発表ですぅ。。。お役に立てませんでしたら、ゴミ箱ぽぉぉおいお願いいたします。
頑張ってくださいねぇ。でわ(*^^*)
m(__)m
Option Explicit
Sub OneInstanceMain()
Dim ws As Worksheet
Dim vAr As Variant
Dim r As Range
Dim w() As Variant
Dim idx() As Variant
Dim dic As Object
Dim n As Long
Dim i As Long
Set ws = ThisWorkbook.Worksheets("G_H_Drive")
Set dic = CreateObject("Scripting.Dictionary")
With ws
Set r = .Cells(1).CurrentRegion
Intersect(.Range(.Rows(r.Row), .Rows(r.Rows.Count)), .Range("E:F")).Clear
Set r = r.Offset(1).Resize(r.Rows.Count - 1)
End With
For Each vAr In r
If Not dic.Exists(vAr.Value) Then
dic(vAr.Value) = Empty
Else
dic(vAr.Value) = dic(vAr.Value) + 1
If dic(vAr.Value) = 1 Then
ReDim Preserve w(n)
w(n) = vAr
n = n + 1
End If
End If
Next
dic.RemoveAll
For i = LBound(w) To UBound(w)
For Each vAr In r
If w(i) = vAr.Value Then
Debug.Print vAr.Column
Select Case vAr.Column
Case 1
dic(w(i)) = dic(w(i)) & "H: " & vAr.Row & ","
Case 2
dic(w(i)) = dic(w(i)) & "G: " & vAr.Row & ","
Case 3
dic(w(i)) = dic(w(i)) & "D: " & vAr.Row & ","
End Select
End If
Next
Next
n = 0
ReDim w(1 To dic.Count, 1 To 2)
idx = dic.keys
For i = LBound(idx) To UBound(idx)
n = n + 1
w(n, 1) = idx(i)
w(n, 2) = Left(dic(idx(i)), Len(dic(idx(i))) - 1)
Next
With ws
.Cells(1, 5).Resize(, 2) = Array("重複名", "ドライブ名、行番号")
.Cells(2, 5).Resize(UBound(w, 1), UBound(w, 2)) = w
End With
Erase w, idx
dic.RemoveAll
End Sub
（隠居Z） 2024/11/21(木) 20:37:49
Option Explicit
Sub test()
Dim ixRow1 As Long
Dim ixCol1 As Long
Dim ixRow2 As Long
Dim ixCol2 As Long
Dim ixRow3 As Long
Dim ixBottom1 As Long
Dim ixBottom2 As Long
Dim ws As Worksheet
Dim sKey1 As String
Set ws = ThisWorkbook.Worksheets(1)
ixBottom1 = ws.UsedRange.Rows.Count
For ixCol1 = 1 To 2
For ixRow1 = 2 To ixBottom1
sKey1 = ws.Cells(ixRow1, ixCol1).Value
If sKey1 = "" Then Exit For
For ixCol2 = ixCol1 + 1 To 3
For ixRow2 = 2 To ixBottom1
If sKey1 = ws.Cells(ixRow2, ixCol2).Value Then
ixBottom2 = ws.Cells(Rows.Count, "E").End(xlUp).Row
For ixRow3 = 2 To ixBottom2
If sKey1 = ws.Cells(ixRow3, "E").Value Then
Exit For
End If
Next
If ixRow3 > ixBottom2 Then
ws.Cells(ixRow3, "E").Value = sKey1
End If
If InStr(1, ws.Cells(ixRow3, "F").Value, ixCol1) = 0 Then
ws.Cells(ixRow3, "F").Value = ws.Cells(ixRow3, "F").Value & ixCol1 & ","
End If
If InStr(1, ws.Cells(ixRow3, "F").Value, ixCol2) = 0 Then
ws.Cells(ixRow3, "F").Value = ws.Cells(ixRow3, "F").Value & ixCol2 & ","
End If
Exit For
End If
Next
Next
Next
Next
End Sub
たぶん、こんな感じ
（ごめんなさい。途中で変数を宣言するのがめんどくさくなって、
コピペでつらつら同じ文言をいっぱい書いてます＾＾；）
これにプラス。
出力された文字（1，2，3）を好きな文字（ドライブ名？）に置き換えるよう
書き足したらよいかと。。。。
ただ、目視で順次みていくやり方を、マクロ化すると大変なので、
エクセルを使うなら、エクセルの機能を存分に使えばかなり楽になると思うし、
処理の途中経過をシートに随時記録していくと、考え方がすっきりすると思います。
たとえば、
1）すべてのファイル名を、E列にコピペ
2）重複の削除の機能を使って、重複のない一覧にする
3）F列に=MATCH($E2,A$2:A$7,0)みたいな式を入れてH列までドラッグ
そのままフィルハンドルをダブルクリック
4）オートフィルターで全部エラーのデータを抽出して削除
みたいなことで、十分かと思います。
さらに表記こだわるなら、数式マスターに再度、いい方法がないか相談してみると
よいかと思います。
で、その手順をマクロ化（自動化）するといいかと思います。
（まっつわん） 2024/11/21(木) 21:23:57
お勉強させて戴きます。m(__)m
（隠居Z） 2024/11/21(木) 22:18:45
Excel2016以降であれば、Power Queryが簡単ですね。 興味がなければ無視してください。 （マナ） 2024/11/21(木) 22:33:24
Excel2024です。
（こちらでは、バージョンが2021までで投稿時の選択肢に2024は無表記でした。）
＞たのお力も借りないととても煩雑になりそうな
やはり、他の力＝CreateObject("Scripting.Dictionary")を利用するべきかも知れませんが
まだ手を付けていないので自前のコードが解決したら改めて調べてみます。
（（む） 2024/11/21(木) 16:35:37 で調べてみますと言いながらまだ調べていません。）
まっつわんさん、アドバイスありがとうございます。
そうです。
ループを多重化するとあたまがくらくらして思考が停止しそうになります。
何でも多重ループにするのはやはり無理がありそうで自前のコードの完成は難しいかもです。
マナさん、Power Queryの利用を教えていただきありがとうございます。
当方、power Query を利用したことが無いのでどれほど簡単になるかもわからないので
興味は有りますがハードルが高そうで2の足を踏んでいます。
（フレミング） 2024/11/22(金) 06:49:00
「（隠居Z） 2024/11/21(木) 20:37:49」
重複が無い場合を含めて書き出す最初のセル（E2)は””で次の（F2）に必ず以下の文字列が記載されます。
（表記は、5行ですが、実際は改行がなく1行で表記されています。）
G: 15,G: 16,G: 17,G: 18,G: 19,G: 20,G: 21,G: 22,G: 23,G: 24,G: 25,G: 26,G: 27,G: 28,
G: 29,G: 30,G: 31,G: 32,G: 33,G: 34,G: 35,G: 36,G: 37,G: 38,H: 39,G: 39,H: 40,G: 40,
H: 41,G: 41,H: 42,G: 42,H: 43,G: 43,H: 44,G: 44,H: 45,G: 45,H: 46,G: 46,H: 47,G: 47,
H: 48,G: 48,H: 49,G: 49,H: 50,G: 50,H: 51,G: 51,H: 52,G: 52,H: 53,G: 53,H: 54,G: 54,
H: 55,G: 55,H: 56,G: 56,H: 57,G: 57,H: 58,G: 58,H: 59,G: 59,H: 60,G: 60,H: 61,G: 61
この表記以後はうまく希望する内容が書き出されています。
（つまりE2，F2の表記は必要ない何かが出力されています。）
「（まっつわん） 2024/11/21(木) 21:23:57」
以下のコードを追加して行番号は有りませんがうまく処理できています。
（「国産 H,G,D」と表記されて 「国産 H26,G102,D88」とは表記されない）
'------------ 追加コード
Dim r As Long
Dim lastRowF As Long
lastRowF = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
'出力された文字（1，2，3）をドライブ名に置き換える
For r = 2 To lastRowF
ws.Cells(r, 6).Value = Replace(ws.Cells(r, 6).Value, "1", "H")
ws.Cells(r, 6).Value = Replace(ws.Cells(r, 6).Value, "2", "G")
ws.Cells(r, 6).Value = Replace(ws.Cells(r, 6).Value, "3", "D")
'最後の文字列「,」は不要なので削除して表示
If Len(ws.Cells(r, 6).Value) > 0 Then
ws.Cells(r, 6).Value = Left(ws.Cells(r, 6).Value, Len(ws.Cells(r, 6).Value) - 1)
End If
Next r
（フレミング） 2024/11/22(金) 09:07:37
書き忘れました。
＞重複が無い場合を含めて書き出す最初のセル（E2)は””で次の（F2）に必ず以下の文字列が記載されます。
なので現在以下のコードを追加して書き出しを修正しています。
' E列とF列の不必要なF2およびF2セルを削除し、上にシフトして詰めて表示する
Range("E2:F2").Delete Shift:=xlUp
（フレミング） 2024/11/22(金) 09:21:56
上にシフトして詰めて表示するコードに不備がありましたので修正しました。
' E列とF列の不必要なF2およびF2セルを削除し、上にシフトして詰めて表示する
Dim lastRowE As Long
Dim hasDataBelow As Boolean
' E列の最終行を取得
lastRowE = ws.Cells(ws.Rows.Count, "E").End(xlUp).row
' 3行目以下に書き込みがあるかチェック
'（何も重複がなくても２行目に不必要な書き込みが出力されるので苦肉の策）
If lastRowE >= 3 Then
hasDataBelow = True '重複有り
Else
hasDataBelow = False '重複なし
End If
If Not hasDataBelow = True Then
ws.Range("E2:F2").Delete Shift:=xlUp
Else
ws.Range("E1:F1").Delete Shift:=xlUp
End If
（フレミング） 2024/11/22(金) 13:24:39
ステップ１：データ取得 -------------------- H G D 山田 森川 岩田 森川 大谷 森川 null 黒川 山田 --------------------
ステップ２：インデックス列の追加 ---------------------------------- H G D インデックス 山田 森川 岩田 1 森川 大谷 森川 2 null 黒川 山田 3 ----------------------------------
ステップ３：ピボット解除 ---------------------------- インデックス 属性 値 1 H 山田 1 G 森川 1 D 岩田 2 H 森川 2 G 大谷 2 D 森川 3 G 黒川 3 D 山田 ----------------------------
ステップ４：列のマージ -------------------- 結合済み 値 H:1 山田 G:1 森川 D:1 岩田 H:2 森川 G:2 大谷 D:2 森川 G:3 黒川 D:3 山田 --------------------
ステップ５：値列でグループ化
新しい列名 操作
カウント 行数のカウント
データ すべての行
---------------------------------- 値 カウント データ 山田 2 [テーブル] 森川 3 [テーブル] 岩田 1 [テーブル] 大谷 1 [テーブル] 黒川 1 [テーブル] ----------------------------------
ステップ６：カウント列で値フィルター ---------------------------------- 値 カウント データ 山田 2 [テーブル] 森川 3 [テーブル] ----------------------------------
ステップ７：カスタム列の追加 = Text.Combine([データ][結合済み],",")
--------------------------------------------------- 値 カウント データ 位置 山田 2 [テーブル] H:1,D:3 森川 3 [テーブル] G:1,H:2,D:2 ---------------------------------------------------
ステップ８：列の削除 ------------------- 値 位置 山田 H:1,D:3 森川 G:1,H:2,D:2 -------------------- （マナ） 2024/11/22(金) 22:15:53
Dictionaryを使ったコード例
Public Sub SampleDic()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
Dim rData As Range
Set rData = ws.Cells(1).CurrentRegion
Set rData = Intersect(rData, rData.Offset(1))
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim col As Range, c As Range
For Each col In rData.Columns
For Each c In col.Cells
If dic.Exists(c.Value) Then
dic(c.Value) = dic(c.Value) & "," & Choose(c.Column, "H", "G", "D") & c.Row
Else
dic(c.Value) = Choose(c.Column, "H", "G", "D") & c.Row
End If
Next
Next
Dim vKey As Variant, i As Long
For Each vKey In dic
If InStr(dic(vKey), ",") > 0 Then
i = i + 1
ws.Cells(i, "E").Value = vKey
ws.Cells(i, "F").Value = dic(vKey)
End If
Next
End Sub
実行結果
|[A] |[B] |[C] |[D]|[E] |[F]
[1] |F1 |F2 |F3 | |EXCEL|H3,G4,D5
[2] |A2 |B2 |Y | |Y |H8,D2
[3] |EXCEL|B3 |C3 | |X |H13,G15
[4] |A4 |EXCEL|C4 | |Z |G10,D10
[5] |A5 |B5 |EXCEL| | |
[6] |A6 |B6 |C6 | | |
[7] |A7 |B7 |C7 | | |
[8] |Y |B8 |C8 | | |
[9] |A9 |B9 |C9 | | |
[10]|A10 |Z |Z | | |
[11]|A11 |B11 |C11 | | |
[12]|A12 |B12 |C12 | | |
[13]|X |B13 |C13 | | |
[14]|A14 |B14 |C14 | | |
[15]|A15 |X |C15 | | |
[16]|A16 |B16 |C16 | | |
（hatena） 2024/11/23(土) 06:07:29
Power Queryのが初めてなので苦戦しています。
何とかステップ2まではたどり着きましたが、
参考画像
https://imgur.com/a/q4zxlq3
ステップ３で停滞しています。
「ピボット解除」の操作が不明で
Power Queryエディターで
「変換」タブに「列のピボット解除」項目があるのでクリックしても
添付図のようには状態にはなりませんでした。
hatenaさん、参考のコードをありがとうございます。
今、他の手法でのアプローチを模索状態なので時間が出来たら試してみます。
（フレミング） 2024/11/23(土) 07:01:02
「インデックス]列を選んで、右クリックメニューから「その他の列のピボット解除」 （マナ） 2024/11/23(土) 07:47:15
Sub test()
Const myFormula1 As String = "=CHOOSE(COLUMN(A1),""G:"",""H:"",""D:"") & MATCH($E2,XXXXX,0)"
Const myFormula2 As String = "=COUNTA(YYYYY)"
Dim rngData As Range
Dim rngResults As Range
Dim rngExist As Range
Dim c As Range
Dim ix As Long
Dim i As Long
Dim s As String
'準備
With Worksheets(1)
Set rngData = .Range("A1").CurrentRegion.Offset(1)
Set rngResults = rngData.Offset(, rngData.Columns.Count + 1).Cells(1)
End With
rngResults.CurrentRegion.ClearContents
ix = rngData.Columns.Count
'重複のないリストの作成
For Each c In rngData.Columns
c.Copy rngResults
Set rngResults = rngResults.End(xlDown).Offset(1)
Next
With rngResults
Set rngResults = rngResults.CurrentRegion
End With
rngResults.RemoveDuplicates Columns:=1, Header:=xlNo
Set rngResults = rngResults(1).CurrentRegion
'各列毎の存在確認
Set rngExist = rngResults.Offset(, 1).Resize(, ix)
With rngExist
.Formula = Replace(myFormula1, "XXXXX", rngData.Columns(1).Address(True, False))
.SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents
.Value = .Value
End With
'重複の確認
rngExist.Resize(, 1).Offset(, rngExist.Columns.Count).Formula _
= Replace(myFormula2, "YYYYY", rngExist.Rows(1).Address(False, False))
'重複のないものを削除
With rngResults.CurrentRegion
.Cells(0, 1).Value = "ファイル名"
.AutoFilter Field:=.Columns.Count, Criteria1:=1
.Offset(1).ClearContents
.AutoFilter
.Columns(.Columns.Count).EntireColumn.ClearContents
.Sort Key1:=.Cells(1), order1:=xlAscending, Header:=xlYes
End With
'文字をまとめる
With rngResults.CurrentRegion
Set rngExist = Intersect(.Cells, .Offset(1, 1))
End With
With rngExist
For Each c In rngExist.Rows
For i = 1 To c.Columns.Count
If c.Cells(i).Value <> Empty Then
s = s & "," & c.Cells(i).Value
End If
Next
c.Cells(1).Value = Mid(s, 2)
s = ""
Next
.Offset(, 1).ClearContents
End With
End Sub
個々にセルの値を読んだり書いたりすると、
時間がかかるので出来るだけまとめて読み書き&編集等ができると、
いいかなと思いました。
(VBAで個々に処理するより、エクセルの機能で出来ることは、
エクセルに任せた方が、処理が速い場合があります。データ数にもよりますが）
飛び飛びのセルの値をカンマでつないで文字を作るところは、
いい案を思いつかなかったので、個々に読み書きしちゃってますが＾＾；
配列変数を使って文字列を編集するようにすると、
シートの書き込みの回数をまとめられるので、高速化が見込めますが、
ちょっと、まだ理解が追い付いてなさそうなので、個々に読み書きするように書きました。
参考まで＞＞
第114回.セル範囲⇔配列（マクロVBA高速化必須テクニック）＞＞
https://excel-ubara.com/excelvba1/EXCELVBA414.html#google_vignette
配列を使う＞＞
http://officetanaka.net/excel/vba/speed/s11.htm
（まっつわん） 2024/11/23(土) 09:56:08
Powerqueryは、現在進行中で結果で出るまでまだ時間がかかりそうです。
頭がクラクラする多重ループを使用せずにDictionaryオブゼクトも利用して
自分が現在作成できる範囲でコード作成してみました。
（達人さんと比べるべきでも無いのですが
すごく長いコードですが何とか結果は出ています。）
おかしな点や改善できる点などアドバイスあればお願いします。
Option Explicit
Sub 重複ドライブチェック()
Dim ws As Worksheet
Dim lastRowA As Long, lastRowB As Long, lastRowC As Long, maxRow As Long
Dim i As Long, writeRow As Long
Set ws = ActiveSheet
'書き出し列の初期化（数式・文字・書式・コメント全てをクリア）
ws.Range("E:F").Clear
ws.Range("E1") = "アドレス"
ws.Range("F1") = "文字列"
ws.Range("H:I").Clear
ws.Range("H1") = "重複"
ws.Range("I1") = "ドライブ名"
' 各列の最終行を取得
lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
lastRowC = ws.Cells(ws.Rows.Count, "C").End(xlUp).row
' 最大の行数を取得
maxRow = Application.WorksheetFunction.Max(lastRowA, lastRowB, lastRowC)
writeRow = 2 ' E列とF列の書き込み開始行
' A, B, C列のセル番地と値を書き出す
For i = 2 To maxRow ' 2行目から開始（1行目は見出し行）
If i <= lastRowA Then
ws.Cells(writeRow, "E").Value = ws.Cells(i, "A").Address(False, False)
ws.Cells(writeRow, "F").Value = ws.Cells(i, "A").Value
writeRow = writeRow + 1
End If
If i <= lastRowB Then
ws.Cells(writeRow, "E").Value = ws.Cells(i, "B").Address(False, False)
ws.Cells(writeRow, "F").Value = ws.Cells(i, "B").Value
writeRow = writeRow + 1
End If
If i <= lastRowC Then
ws.Cells(writeRow, "E").Value = ws.Cells(i, "C").Address(False, False)
ws.Cells(writeRow, "F").Value = ws.Cells(i, "C").Value
writeRow = writeRow + 1
End If
Next i
'E,F範囲内をF列をソートキーとしてソート
With ws.Sort
.SortFields.Clear
.SortFields.Add key:=Range("F1"), SortOn:=xlSortOnValues, Order:=xlAscending
.SetRange Range("E1:F" & ws.Cells(ws.Rows.Count, "E").End(xlUp).row)
.Header = xlYes
.Apply
End With
'F列の重複文字列を赤色で着色
Dim lastRowF As Long
Dim ii As Long, j As Long
lastRowF = Cells(Rows.Count, "F").End(xlUp).row
For i = 1 To lastRowF
For j = i + 1 To lastRowF
If Cells(i, "F").Value = Cells(j, "F").Value Then
Cells(i, "F").Font.Color = RGB(255, 0, 0)
Cells(j, "F").Font.Color = RGB(255, 0, 0)
End If
Next j
Next i
' F列で赤色で着色されているセルの文字列をH2から書き出す
' (同じ行のE列の値をI2から書き出す）
Dim k As Long
Dim hRow As Long
hRow = 2
For k = 2 To lastRowF
If ws.Cells(k, "F").Font.Color = RGB(255, 0, 0) Then
ws.Cells(hRow, "H").Value = ws.Cells(k, "F").Value
ws.Cells(hRow, "I").Value = ws.Cells(k, "E").Value
hRow = hRow + 1
End If
Next k
'重複DATAは一つにまとめて出力
Dim lastRowH As Long
Dim dict As Object
Dim cell As Range
Dim key As Variant
Dim outputRow As Long
' 最終行を取得
lastRowH = ws.Cells(ws.Rows.Count, "H").End(xlUp).row
' ディクショナリオブジェクトを作成
Set dict = CreateObject("Scripting.Dictionary")
' データを収集
For Each cell In ws.Range("H2:H" & lastRowH)
If Not dict.Exists(cell.Value) Then
dict(cell.Value) = cell.Offset(0, 1).Value
Else
dict(cell.Value) = dict(cell.Value) & "," & cell.Offset(0, 1).Value
End If
Next cell
' 結果を出力する前に書き出しセルを再度初期化
ws.Range("H:I").Clear
ws.Range("H1") = "重複"
ws.Range("I1") = "ドライブ名"
outputRow = 2
'出力
For Each key In dict.Keys
ws.Cells(outputRow, "H").Value = key
ws.Cells(outputRow, "I").Value = dict(key)
outputRow = outputRow + 1
Next key
MsgBox "完了しました。"
End Sub
（フレミング） 2024/11/23(土) 10:43:01
For i = 1 To lastRowF
j = i + 1
'For j = i + 1 To lastRowF
'If Cells(i, "F").Value = Cells(j, "F").Value Then
If Cells(i, "F").Value = Cells(j, "F").Value Then
Cells(i, "F").Font.Color = vbRed 'RGB(255, 0, 0)
Cells(j, "F").Font.Color = vbRed 'RGB(255, 0, 0)
End If
'Next j
Next i
ここはこんな感じかなぁ。。。よく精査してないけど、直感的に＾＾；
あと、せっかく「でぃくしょなりーオブジェクト」を使うなら、
セルのアドレスをシート上に展開するのは無駄でしょう。。。
後で見たいのかなぁ。。。。
（まっつわん） 2024/11/23(土) 12:38:11
>'A列､B列､C列の各セルの文字列を比較し､ >'一致する場合にE列に該当する文字列､F列に列名を記載する >'"C"列全てが一致する場合は "A, B, C"、 >'"B"列が一致する場合は、"A, B"、"A, C"、"B, C" と記載する。
単純に考えれば
Sub test()
Dim a, b, i&, ii&, iii&, n&, x, y
With Sheets("G_H_Drive")
a = .[a1].CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
For ii = 1 To UBound(a, 2) - 1
For i = 1 To UBound(a, 1)
If a(i, ii) <> "" Then
For iii = ii + 1 To UBound(a, 2)
x = Application.Match(a(i, ii), Application.Index(a, 0, iii), 0)
If IsNumeric(x) Then
y = Application.Match(a(i, ii), Application.Index(b, 0, 1), 0)
If IsError(y) Then n = n + 1: b(n, 1) = a(i, ii): b(n, 2) = Chr(64 + ii): y = n
b(y, 2) = b(y, 2) & "," & Chr(64 + iii)
a(x, iii) = "": Exit For
End If
Next
End If
Next
Next
With .[e1].Resize(, 2)
.CurrentRegion.ClearContents
.Value = [{"ITEM","FOUND"}]
.Rows(2).Resize(n) = b
End With
End With
End Sub
（jindon） 2024/11/23(土) 14:24:45
ピボットを解除して「列のマージ」を行いましたが
「ステップ４」のようにはH:1とは表示されずに
添付画像のように1H:と逆に表示されてしまいます。
ステップ４：列のマージ
-------------------- 結合済み 値 H:1 山田 G:1 森川 D:1 岩田 H:2 森川 G:2 大谷 D:2 森川 G:3 黒川 D:3 山田 --------------------
又、ステップ4では属性やインデックスのラベルの列が有りませんが
もう必要ないので削除されているのでしょうか？
牛ほなみの進行でステップ8にたどり着くのに時間が必要な状態です。
まっつわん、アドバイスありがとうございます。
すいません。
まだいただいたコードの検証は行っていません。
（powerqueryの操作を追いかけていて時間が取れません。）
＞後で見たいのかなぁ。。。。
そうです。
コードを実行して確認が取れてから次の工程のコードを書くようにしているので
無駄なことが多くコードも長くなりがちです。
jindonさん、アドバイスありがとうございます。
すいません。
まだいただいたコードの検証は行っていません。
（powerqueryの操作を追いかけていて時間が取れません。）
ループの多重は頭がクラクラして思考が追いついていかないので
ループ回数は極力少なくするように心がけています。
（フレミング） 2024/11/23(土) 16:10:24
> ループの多重は頭がクラクラして思考が追いついていかないので > ループ回数は極力少なくするように心がけています。
今のコードよりましだと思うけど... それに、今のコードはとてつもない遠回りをしていと思うので、考え方をアップしただけ。
ま、がんばって （jindon） 2024/11/23(土) 16:20:31
>Exit Forは不要かもしれません。 確かに... 最初はMatchメソッドではなく、すべてループで処理しようとしたのでその名残です。 (ループの方が、多少速くなると思いますので) それとセルアドレスなら簡単に取得できます。 （jindon） 2024/11/23(土) 16:43:00
あ、気にしなくていいですし、
もうおなか一杯かもしれませんよね。
無視していただいてもかまいません。
こちらはこちらで、暇な時間に勉強した成果をUpしてるだけで、
その成果が、質問者さんの参考になればよりよいなぁと思っているだけです。
(せっかく書いたのに消して終わりだともったいない感じなので＾＾；）
データを個別に縦一列に並べなおすくらいなら、
セルの書式設定で色を付けて、
それを目印に書き出すのもありかなぁと思いました。
（データ量が多くなると重くならないか心配＾＾；）
Option Explicit
Sub test005()
Const myFormula As String = "=COUNTIF(XXXXX,A2)>1"
Dim rngData As Range
Dim rngResults As Range
Dim vntResults As Variant
Dim vv As Variant
Dim c As Range
Dim sKey As String
Dim sDrive As String
Dim ixRow As Long
Dim i As Long
'シートの初期化(※タイトル行、元データは入力済とする）
With Worksheets("G_H_Drive")
Set rngData = .Range("A1").CurrentRegion.Offset(1)
Set rngResults = .Range("E1:F1").Resize(rngData.Count).Offset(1)
.Cells.FormatConditions.Delete
End With
rngResults.CurrentRegion.Offset(1).ClearContents
vntResults = rngResults.Value
'データ範囲に条件付き書式設定
With rngData.FormatConditions
.Delete
.Add Type:=xlExpression, _
Formula1:=Replace(myFormula, "XXXXX", rngData.Address)
.Item(1).Interior.Color = vbYellow
End With
'色の付いたセルを検索
For Each c In rngData
If c.DisplayFormat.Interior.Color = vbYellow Then
sKey = c.Value
sDrive = c.Address(False, False)
'書き出し位置の検索
ixRow = 0
With WorksheetFunction
vv = .Transpose(.Index(vntResults, 0, 1))
On Error Resume Next
ixRow = .Match(sKey, vv, 0)
On Error GoTo 0
End With
If ixRow = 0 Then
For ixRow = LBound(vv) To UBound(vv)
If vv(ixRow) = Empty Then Exit For
Next
End If
'配列変数に記録
vntResults(ixRow, 1) = sKey
If vntResults(ixRow, 2) = Empty Then
vntResults(ixRow, 2) = sDrive
Else
vntResults(ixRow, 2) = vntResults(ixRow, 2) & "," & sDrive
End If
'データ数の記録
If i < ixRow Then i = ixRow
End If
Next
'シートに書き出し
rngResults.Resize(i).Value = vntResults
End Sub
（まっつわん） 2024/11/23(土) 21:49:57
PowerQueryは、ぶっつけ本番で行うより、 基礎的な知識を学習してからの方が良さそうに思いますが、 結果が出るというのも大事なので。
以下、ステップについては、マナさんご提示のものに準じます。
ステップ４：列のマージ 列のマージは、Ctrlキーを押しながら、属性列＞インデックス列の順に選択する。 他の列については、ステップ５でグループ化するので、削除しなくてもよい。（削除しても問題はない）
ステップ５：値列でグループ化 グループ化ダイアログで「詳細設定」にチェック。 ダイアログ下部にある「集計の追加」を押下し、 ２段目に「データ」「すべての行」とする。
ステップ６：カウント列で値フィルター カウント列の▼を押下し、「１」のチェックを外す
ステップ７：カスタム列の追加 「カスタム列」＞カスタム列の式 に提示されている式をコピペ。
ステップ８：列の削除 カウント列とデータ列を選択して「列の削除」 最後にホームの「閉じて読み込む」
以下蛇足。 質問者は別のニックネームで質問した際に、Dictionaryを用いたコードも提示されているので、 初見ということはないはずです。全く別人のテイを装うなら、ボロを出さずにしっかりやってください。 オブゼクト、全角スペース１文字後の「？」、Officeテーマが黒で、3アウト。 （ベクトル） 2024/11/24(日) 09:49:41
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.