難問 条件に合致した抽出結果

いつもお世話になっております。
下記のように表があります。
Ｂ列のコードとＥ列のコードで
同じｺｰﾄﾞで担当が違うコードと担当
をＨ列　　 Ｉ列　 Ｊ列に
抽出結果を出したいです。

1.空白も違うとみなし
A001 前島
A004 土井

2.加えて
どちらかにｺｰﾄﾞがある場合も
抽出します。　　　　　　　　

ｺｰﾄﾞは一つしか存在しません

わかる方おしえてくれませんでしょうか

　　　　　　　　　　　　　　　　　　　抽出結果
コード　担当　　コード　担当　　　コード　担当　担当
Ｂ列　　Ｃ列　　Ｅ列　Ｆ列　　　　Ｈ列　　 Ｉ列　 Ｊ列
A001 　 前島 A001 A001 前島
A002 福井 A002 長野 A002 福井 長野
A003 近藤 A003 近藤 A004 土井
A004 土井 A004 A005 佐藤 金井
A005 佐藤 A005 金井 A006 福岡
A006　 福岡 A008　 福岡 A008　 福岡

No.1 回答者： fujillin 回答日時： 2021/07/03 23:29

こんばんは

VBAとのことなので、一つの考え方の手順例ですが・・・

1）B列、E列の値をH列に転記し、重複を削除（RemoveDuplicatesメソッド）
　結果、H列に全てのコードリストができる
　（必要なら、結果をソート）

2）I、J列にC、F列の値をVLOOKUP関数を入力して転記。
　　.Value = .Value で、関数値を定数に変換

3）I、J列の値を比較して、値が同じ行のH:J列を削除

※ エクセルの機能を利用する方法ですが、コードそのものは比較的簡単にできると思います。
※ C列、F列内にはコードの重複は無いものと仮定しています。
　（仮定が成立しない場合は、上記ではうまくいきません）

＞難問 条件に合致した抽出結果
どこらあたりが、「難問」なのでしょうか？

この回答へのお礼

ありがとうございます。

お礼日時：2021/07/04 08:21

No.2 回答者： めぐみん_ 回答日時： 2021/07/04 06:48

具体的にどこに行き詰まっているのかを書かれた方が良いのかも？

過去の質問を思い出しても、以前に回答した方法で解ける場合でも、何故か使い方にミスがあるように感じた事がありました

例えば『○○の方法を用いてみたいのだけど・・・』とか手段さえわからないのなら、過去のやり取りの意味は薄いと疑問はあります
解けたから締め切るのも自由ですが、理解できるまで続ける事が良かったのではないかと

方法の一例は既に出ていますが、ディクショナリーを主に使われてたようでしたので、それを極めたいならその解き方に絞るなどが良いと思いますよ

どちらかと言えばVisualBasicやC#とかに移行してみると、考え方も変わります（私は変わりました）

この回答へのお礼

すみません
がんばつてみます。

お礼日時：2021/07/04 08:23

No.3 回答者： めぐみん_ 回答日時： 2021/07/04 09:21

No.2です。

ExcelVBAに限定してやっていくのであれば、まずはExcelが持つ機能によるデータ解析などの参考書を実際に試して身に付け、過去の考え方を改め今のExcelに合わせていくのも良いかもしれません。
あとはその機能をVBAから操作する（マクロの自動記録など）事を繰り返してみるのが宜しいのかも。

何を目指すのか？によってですね。
私個人は他言語もやりたいと思ってはいますので、Excelの独自機能に頼らない方法を模索しては砕け散ってますけどね。

この回答へのお礼

いつも有難うございます。
いろいろ教えていただきありがとうございます。

お礼日時：2021/07/04 11:17

No.4 ベストアンサー 回答者： tatsumaru77 回答日時： 2021/07/04 10:21

レイアウトが画像の通りだとします。

以下のマクロを標準モジュールに登録してください。

Option Explicit

Public Sub 抽出作業()
Dim dicT1 As Object
Dim dicT2 As Object
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim maxrow3 As Long
Dim wrow As Long
Dim key As Variant
Dim ws As Worksheet
Set dicT1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicT2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set ws = ActiveSheet
maxrow1 = ws.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最大行取得
maxrow2 = ws.Cells(Rows.Count, "E").End(xlUp).Row 'E列の最大行取得
maxrow3 = ws.Cells(Rows.Count, "H").End(xlUp).Row 'H列の最大行取得
If maxrow3 > 3 Then
ws.Range("H4:J" & maxrow3).Value = ""
End If
For wrow = 4 To maxrow1
dicT1(ws.Cells(wrow, "B").Value) = ws.Cells(wrow, "C").Value
Next
For wrow = 4 To maxrow2
dicT2(ws.Cells(wrow, "E").Value) = ws.Cells(wrow, "F").Value
Next
wrow = 4
For Each key In dicT1.keys
If dicT2.exists(key) = True Then
If dicT1(key) <> dicT2(key) Then
ws.Cells(wrow, "H").Value = key
ws.Cells(wrow, "I").Value = dicT1(key)
ws.Cells(wrow, "J").Value = dicT2(key)
wrow = wrow + 1
dicT1.Remove (key)
dicT2.Remove (key)
End If
Else
ws.Cells(wrow, "H").Value = key
ws.Cells(wrow, "I").Value = dicT1(key)
wrow = wrow + 1
dicT1.Remove (key)
End If
Next
For Each key In dicT2.keys
If dicT1.exists(key) = False Then
ws.Cells(wrow, "H").Value = key
ws.Cells(wrow, "J").Value = dicT2(key)
wrow = wrow + 1
dicT2.Remove (key)
End If
Next
MsgBox ("完了")
End Sub

この回答へのお礼

ありがとうございます。
思い通りでした。
とても嬉しいです。
しかし、わたしの無力が浮き出て
とてもわたし自身とても無念です。
どのように考えてできるのでしょうか

本当　ありがとうございました。

お礼日時：2021/07/04 11:20

No.5 回答者： めぐみん_ 回答日時： 2021/07/04 11:16

書き出した後でコードを基準に並び替えが必要であれば・・・・ファイト！

Sub megu()
Dim myDic As Object
Dim r As Range
Dim v As Variant

Set myDic = CreateObject("Scripting.Dictionary")

For Each r In Range("B4", Cells(Rows.Count, "B").End(xlUp))
myDic.Add r.Value, Array(r.Value, r.Offset(, 1).Value, "")
Next

For Each r In Range("E4", Cells(Rows.Count, "E").End(xlUp))
If myDic.Exists(r.Value) Then

v = myDic(r.Value)
If r.Offset(, 1).Value <> v(1) Then
v(2) = r.Offset(, 1).Value
myDic(r.Value) = v
Else
myDic.Remove (r.Value)
End If

Else
myDic.Add r.Value, Array(r.Value, "", r.Offset(, 1).Value)
End If
Next

Range("H4").Resize(myDic.Count, 3).Value = _
Application.Transpose(Application.Transpose(myDic.Items))

Set myDic = Nothing

End Sub

この回答へのお礼

いつも有難うございます。
本当いつも有難うございます。

お礼日時：2021/07/04 15:19