【VBA】異なる形式のリストを統合する（日本語の表現揺れに対応）
異なる形式のリストが２つあったとき、リストBの特定列から情報をコピーして、リストAに書き出すというVBAマクロを作りました。
これを使えば、2000件のデータ照合＆書き出しが10秒位で終わります。
２つのリストのデータ総数が不一致、記載順不同でも使用可能。
要するに、２つのリスト情報を纏めることができますよ！ってヤツです。
●できること＆特徴
上述の通り、2つのリストを１つに集約するマクロです。
参考として「漫画タイトルが一致する行のコメントを転記する」例です。
右：読んだあとの感想リスト（リストB）
タイトルが一致する行を見極めて、リストB（画像右）のB列の値をコピーして、リストA（画像左）のD列に貼り付けています。
これを実行すると、リストAへ情報集約されます。
ワークシート関数の「VLOOKUP関数」の上位互換機能と言えば、イメージしやすいでしょうか？
何が上位互換なのかと言うと…
・日本語の表現揺れに対応。
・検索列（キー列）比較の際に、詳細な検索条件指定が可能。
・リスト最終行の指定が不要（自動取得）。
・検索列（キー列）が必ず左側に来なければならないという制約がない。
など。
実務では、日本語の表現揺れが酷いリストに出くわすことも多々あります。例えば、ハイフンの表記（「－」や「—」(環境文字）などが混在）がリスト間でバラバラだと、VLOOKUP関数では太刀打ちできません。
こうした日本語の表現揺れを吸収したうえで２つのリストを照合・集約する等、自分好みにアレンジすることで「処理結果の精度を高める」ことが出来ます。
今回紹介するものには、予め３つのアレンジ（検索オプション）を見込んであります。
・検索キーにおいて、「 」スペースの有無を区別しない
・検索キーにおいて、「・」中点の有無を区別しない
・検索キーにおいて、ハイフンの表記揺れを統一
これだけでもキー検索のヒット率が上がる筈です。
（リストの形式にも依ると思いますが…）
VBAで書いてあるので、何かと「融通が利く」ことが最大のメリットです。ぜひ紹介するコードをベースにして、自分好みの追加条件等を加えて使ってみて下さい。
（もし追加の検索条件を加えるんだったら、正規表現による条件指定とか、環境文字の表記揺れ対策を追加するとかが有力候補ですかね。）
●VBAコード
どんな事ができるか分かったところで、中身の紹介です。
ユーザーフォーム部分
今回、汎用性を高めるため入力用のユーザーフォームを作成しました。
テキストボックスに必要情報を入れて、実行ボタンを押すとマクロが始まります。
検索オプションは、下段のチェックボックスで切り替え可能。
VBAコード配布時のセキュリティ性を考慮して、上記ユーザーフォームのコントロールは全て動的生成されるようにコーディングしました。
ということで、まずはユーザーフォーム部分のコードがこちら。
'モジュールレベル変数
Dim WithEvents oButton1 As MSForms.CommandButton '実行ボタン
Dim WithEvents oButton2 As MSForms.CommandButton 'リストAのパス取得ボタン
Dim WithEvents oButton3 As MSForms.CommandButton 'リストBのパス取得ボタン
Dim WithEvents oTextBox1 As MSForms.TextBox 'リストAのパス入力用テキストボックス
Dim WithEvents oTextBox2 As MSForms.TextBox 'リストBのパス入力用テキストボックス
Dim WithEvents oCheckBox1 As MSForms.CheckBox 'キー検索用オプション（全角半角）
Dim WithEvents oCheckBox2 As MSForms.CheckBox 'キー検索用オプション（ハイフンの統一）
Dim WithEvents oCheckBox3 As MSForms.CheckBox 'キー検索用オプション（ハイフンの統一）
Private Sub UserForm_Initialize()
'ユーザーフォームのウィンドウサイズ設定
UserForm1.Width = 700
UserForm1.Height = 570
'タイトルラベルと説明文ラベルを生成
Dim i As Integer
Dim oLabel As Control
For i = 1 To 2
Set oLabel = UserForm1.Controls.Add("Forms.Label.1", "Label" & i, True)
With oLabel
.Top = 10 + (i - 1) * 30
.Left = 30
.Height = 30 + (i - 1) * 100
.Width = 650
.Font.Name = "MS UI Gothic"
Select Case i
Case 1
.Caption = "リストBの特定列から情報をコピーして、リストAの特定列へ書き出すマクロ。"
.Font.Size = 18
Case 2
.Caption = " ～使用例～" & vbCrLf & _
"異なる形式のリストAとリストBがあったとします。" & vbCrLf & _
" ・リストA…我が家の漫画リスト（B列「タイトル」、D列は空白）" & vbCrLf & _
" ・リストB…読んだあとの感想リスト （A列「タイトル」、B列「コメント」）" & vbCrLf & _
"漫画のタイトル（キー列の値）が一致する行を見極めて、同じタイトルであればリストBのB列（特定列）の値をコピーして、" & vbCrLf & _
"リストAのD列（特定列）へ貼り付けます。つまり、リストAへ情報集約できます。" & vbCrLf & vbCrLf & _
" ～特徴～" & vbCrLf & _
"ワークシート関数【VLOOKUP関数】の上位互換機能です。" & vbCrLf & _
"検索オプションにて、日本語の表記揺れや環境文字に一部対応。" & vbCrLf & _
"データ総数不一致、記載順不同な2つのリスト間でも使用可能。"
.Font.Size = 11
End Select
End With
Next i
'各ラベルを生成
For i = 3 To 18
Set oLabel = UserForm1.Controls.Add("Forms.Label.1", "Label" & i, True)
With oLabel
.Top = 130 + (i - 1) * 25
.Left = 30
.Height = 25
.Width = 90
.Font.Size = 12
.Font.Name = "MS UI Gothic"
Select Case i
Case 3
.Caption = "リストA"
.Font.Size = 18
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 4
.Caption = "パス"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 5
.Caption = "シート名"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 6
.Caption = "見出し行数" '& vbCrLf & "(データ本文より上の行数)"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 7
.Caption = "キー列（検索列）"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 8
.Caption = "特定列（貼付先）"
.Left = .Left + 250
.Top = .Top - 35
.BackColor = RGB(255, 201, 29) 'イエロー
Case 9
.Caption = "リストB"
.Font.Size = 18
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 10
.Caption = "パス"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 11
.Caption = "シート名"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 12
.Caption = "見出し行数"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 13
.Caption = "キー列（検索列）"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 14
.Caption = "特定列（コピー元）"
.Left = .Left + 250
.Top = .Top - 35
.BackColor = RGB(135, 190, 98) 'グリーン
Case 15
.Caption = "キー列の検索オプション"
.Width = 200
.Font.Size = 18
Case 16
.Caption = "「 」スペースの有無を区別しない"
.Top = 500
.Left = 50
Case 17
.Caption = "「・」の有無を区別しない"
.Top = 500
.Left = 180
Case 18
.Caption = "ハイフンを統一" & vbCrLf & "（表記揺れ対策）"
.Top = 500
.Left = 310
End Select
End With
Next
'各テキストボックスを生成
Dim oTextBox As Control
For i = 1 To 10
'テキストボックス(TextBox)の設定
Set oTextBox = UserForm1.Controls.Add("Forms.TextBox.1", "TextBox" & i, True)
With oTextBox
.Top = 230 + (i - 1) * 25 - 2 '-2は微調整用（LabelとTextBoxの高さ合わせ）
.Left = 30 + 100
.Height = 18
.Width = 100
.Font.Size = 12
.Font.Name = "MS UI Gothic"
Select Case i
Case 1
.Value = "リストA" 'Sheet1
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 2
.Value = "2"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 3
.Value = "B"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
Case 4
.Value = "D"
.Left = .Left + 250
.Top = .Top - 30
.BackColor = RGB(255, 201, 29) 'イエロー
Case 5
.Visible = False
Case 6
.Visible = False
Case 7
.Value = "リストB" 'Sheet2
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 8
.Value = "3"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 9
.Value = "A"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
Case 10
.Value = "B"
.Left = .Left + 250
.Top = .Top - 30
.BackColor = RGB(135, 190, 98) 'グリーン
End Select
End With
Next i
'イベント付きのモジュールレベル変数を生成
Set oButton1 = UserForm1.Controls.Add("Forms.CommandButton.1", "oCommandButton1", True)
With oButton1 '実行ボタン
.Caption = "実行"
.Top = 50
.Left = 550
.Height = 70
.Width = 100
.Font.Size = 18
.Font.Name = "MS UI Gothic"
.BackColor = RGB(221, 221, 255) '紫
End With
Set oButton2 = UserForm1.Controls.Add("Forms.CommandButton.1", "oCommandButton2", True)
With oButton2 'リストAのパス取得ボタン
.Caption = "パス取得"
.Top = 205 - 2
.Left = 60
.Height = 18
.Width = 60
.Font.Size = 12
.Font.Name = "MS UI Gothic"
.BackColor = RGB(221, 221, 255) '紫
End With
Set oButton3 = UserForm1.Controls.Add("Forms.CommandButton.1", "oCommandButton3", True)
With oButton3 'リストBのパス取得ボタン
.Caption = "パス取得"
.Top = 355 - 2
.Left = 60
.Height = 18
.Width = 60
.Font.Size = 12
.Font.Name = "MS UI Gothic"
.BackColor = RGB(221, 221, 255) '紫
End With
Set oTextBox1 = UserForm1.Controls.Add("Forms.TextBox.1", "oTextBox1", True)
With oTextBox1 'リストAのパス入力用テキストボックス
.Value = "C:\Users\***\Note関係\Folder1\リストA.xlsm"
.Top = 205 - 2
.Left = 130
.Height = 18
.Width = UserForm1.Width - 150
.Font.Size = 12
.Font.Name = "MS UI Gothic"
.BackColor = RGB(255, 242, 204) 'ライトイエロー
End With
Set oTextBox2 = UserForm1.Controls.Add("Forms.TextBox.1", "oTextBox2", True)
With oTextBox2 'リストBのパス入力用テキストボックス
.Value = "C:\Users\***\Note関係\Folder1\テスト検証用\リストB.xlsm"
.Top = 355 - 2
.Left = 130
.Height = 18
.Width = UserForm1.Width - 150
.Font.Size = 12
.Font.Name = "MS UI Gothic"
.BackColor = RGB(226, 239, 218) 'ライトグリーン
End With
Set oCheckBox1 = UserForm1.Controls.Add("Forms.CheckBox.1", "oCheckBox1", True)
With oCheckBox1 'キー検索用オプション（スペースの有無を区別しない）
.Value = True
.Top = 500
.Left = 30
.Height = 18
.Width = 18
End With
Set oCheckBox2 = UserForm1.Controls.Add("Forms.CheckBox.1", "oCheckBox2", True)
With oCheckBox2 'キー検索用オプション（｢･｣の有無を区別しない）
.Value = True
.Top = 500
.Left = 160
.Height = 18
.Width = 18
End With
Set oCheckBox3 = UserForm1.Controls.Add("Forms.CheckBox.1", "oCheckBox3", True)
With oCheckBox3 'キー検索用オプション（ハイフン統一）
.Value = True
.Top = 500
.Left = 290
.Height = 18
.Width = 18
End With
End Sub
'実行ボタンのクリック時
Private Sub oButton1_Click()
'ユーザーフォームの入力データを配列StrArr()へ格納
Dim StrArr() As String
ReDim StrArr(0 To 10)
For i = 0 To 10
If i = 0 Then
StrArr(0) = oTextBox1.Value 'リストAのパス
ElseIf i = 6 Then
StrArr(6) = oTextBox2.Value 'リストBのパス
Else
For Each Control In UserForm1.Controls
If Control.Name = "TextBox" & i Then
StrArr(i) = Control.Value 'TextBox1～10の値を配列StrArrへ格納
End If
Next
End If
Next
'標準モジュールの「main1」プロシージャを呼び出す。引数にStrArr()と検索オプションを渡す。
Call main1(StrArr(), oCheckBox1.Value, oCheckBox2.Value, oCheckBox3.Value)
'ユーザーフォームを閉じる
Unload UserForm1
End
End Sub
Private Sub oButton2_Click()
'リストAのパス取得
oTextBox1.Value = Application.GetOpenFilename(FileFilter:="Excelブック(*.xlsx;*.xlsm;*.xls;),")
End Sub
Private Sub oButton3_Click()
'リストBのパス取得
oTextBox2.Value = Application.GetOpenFilename(FileFilter:="Excelブック(*.xlsx;*.xlsm;*.xls;),")
End Sub
'コントロールのサイズ調整（TextBox（パス入力欄）の幅を追従させる）
Private Sub UserForm_Resize()
If UserForm1.Width > 700 Then
oTextBox1.Width = UserForm1.Width - 150
oTextBox2.Width = UserForm1.Width - 150
End If
End Sub
'ユーザーフォームのサイズ変更
Private Sub UserForm_Activate()
Call ResizeForm '標準モジュールの「ResizeForm」プロシージャを呼び出す。
End Sub簡略化のため、エラー処理は抜いてあります。
これを、VBEのフォームモジュールへコピペして下さい。
※VBEのフォームモジュールを表示する方法は下図の通り。
まずブックを開いた状態で「Alt+F11」を押して、VBEを開きます。
標準モジュール部分
続いて、メイン処理部のコードです。
処理概要
１．ユーザーフォームから引数を受け取る。
２．リストAのキー列と、リストBのキー配列を全て配列へ格納。
ここで日本語の表記揺れを吸収する。
適宜アレンジする場合もここで修正を加える。
３．リストAの配列と、リストBの配列と比較。
一致する要素が見つかれば、当該行に相当する「リストBの特定列」
の値を取得。
４．取得した値をリストAへ書き出す。
メイン処理部のコードがこちら。
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Const GWL_STYLE = -16
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_THICKFRAME = &H40000
Dim hWnd As LongPtr
'ユーザーフォームを自動で開く
Private Sub Auto_Open()
UserForm1.Show
End Sub
'ユーザーフォームのサイズ可変＋最大化ボタン＋最小化ボタン追加
Public Sub ResizeForm()
hWnd = GetActiveWindow()
Dim style As Long
style = GetWindowLong(hWnd, GWL_STYLE)
style = style Or WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MINIMIZEBOX
SetWindowLong hWnd, GWL_STYLE, style
DrawMenuBar hWnd
End Sub
Public Sub main1(ByRef Prm() As String, ByVal Flag1 As Boolean, ByVal Flag2 As Boolean, ByVal Flag3 As Boolean)
'引数を確認
'Debug.Print "Prm(0)= " & Prm(0) 'パス
'Debug.Print "Prm(1)= " & Prm(1) 'シート名
'Debug.Print "Prm(2)= " & Prm(2) '見出し行
'Debug.Print "Prm(3)= " & Prm(3) '共通項目のデータ列
'Debug.Print "Prm(4)= " & Prm(4) '貼付け先の列
'Debug.Print "Prm(5)= " & Prm(5) '無し
'Debug.Print "Prm(6)= " & Prm(6) 'パス
'Debug.Print "Prm(7)= " & Prm(7) 'シート名
'Debug.Print "Prm(8)= " & Prm(8) '見出し行
'Debug.Print "Prm(9)= " & Prm(9) '共通項目のデータ列
'Debug.Print "Prm(10)= " & Prm(10) 'コピーする列
'Debug.Print "Flag1= " & Flag1 '「 」の有無を区別しない
'Debug.Print "Flag2= " & Flag2 '「・」の有無を区別しない
'Debug.Print "Flag3= " & Flag2 'ハイフン統一
'処理時間を計測
Debug.Print "計測を開始しました"
Dim startTime As Double
startTime = Timer
'リストA
'Dim wb1 As Workbook
Dim st1 As Worksheet
Dim LastRow1 As Long
Dim Data1 As Variant
Dim Data1_temp() As String 'Data1の一時保管用
'Set wb1 = Workbooks.Open(Prm(0))
Set st1 = Workbooks.Open(Prm(0)).Sheets(Prm(1))
LastRow1 = st1.Cells(Rows.Count, Prm(3)).End(xlUp).Row
Set Data1 = st1.Range(Prm(3) & Prm(2) + 1 & ":" & Prm(3) & LastRow1) 'キー列の値を配列へ代入
Dim Cnt As Long
ReDim Data1_temp(1 To LastRow1 - Prm(2))
For Cnt = 1 To LastRow1 - Prm(2)
Data1_temp(Cnt) = Data1(Cnt, 1).Value 'Replace処理をすると元の値が変わってしまうため、元の値が変わる前にダミー配列(Data1_Temp)に代入して残しておく。
If Flag1 = True Then
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), " ", "", compare:=vbTextCompare) '空白を削除
ElseIf Flag2 = True Then
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "・", "", compare:=vbTextCompare) '「・」を削除
ElseIf Flag3 = True Then
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "―", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "‐", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "－", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "～", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), ChrW(&H2014), "ー") 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), ChrW(&H207B), "ー") 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), ChrW(&H208B), "ー") 'ハイフンを統一
Data1(Cnt, 1) = Replace(Data1(Cnt, 1), ChrW(&HFF70), "ー") 'ハイフンを統一
End If
Next
Debug.Print "途中経過１：" & Timer - startTime & "秒"
'リストB
'Dim wb2 As Workbook
Dim st2 As Worksheet
Dim LastRow2 As Long
Dim Data2 As Variant
Dim Data2_temp() As String 'Data2の一時保管用
'Set wb2 = Workbooks.Open(Prm(6))
Set st2 = Workbooks.Open(Prm(6)).Sheets(Prm(7))
LastRow2 = st2.Cells(Rows.Count, Prm(9)).End(xlUp).Row
Set Data2 = st2.Range(Prm(9) & Prm(8) + 1 & ":" & Prm(9) & LastRow2) 'キー列の値を配列へ代入
ReDim Data2_temp(1 To LastRow2 - Prm(8))
For Cnt = 1 To LastRow2 - Prm(8)
Data2_temp(Cnt) = Data2(Cnt, 1).Value 'Replace処理をすると元の値が変わってしまうため、元の値が変わる前にダミー配列(Data2_Temp)に代入して残しておく。
If Flag1 = True Then
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), " ", "", compare:=vbTextCompare) '空白を削除
ElseIf Flag2 = True Then
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), "・", "", compare:=vbTextCompare) '「・」を削除
ElseIf Flag3 = True Then
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), "―", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), "‐", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), "－", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), "～", "ー", compare:=vbTextCompare) 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), ChrW(&H2014), "ー") 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), ChrW(&H207B), "ー") 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), ChrW(&H208B), "ー") 'ハイフンを統一
Data2(Cnt, 1) = Replace(Data2(Cnt, 1), ChrW(&HFF70), "ー") 'ハイフンを統一
End If
Next
Debug.Print "途中経過２：" & Timer - startTime & "秒"
'共通項目の値が一致するかどうか比較する
Dim i As Long 'st1のデータ項目数（1~n個）
Dim r As Long 'st2のデータ項目数（1～n個）
Dim DataArr() As String '検索結果を格納する配列
Dim Num As Long '配列の要素数
i = 1
Num = 0
For i = 1 To LastRow1 - Prm(2) 'st1データの最初から最後まで、１つづつ処理
r = 1 '変数rの初期化
Do
If Data1(i, 1) = Data2(r, 1) Then '一致する名称が見つかったら
Num = Num + 1
ReDim Preserve DataArr(0 To Num)
DataArr(Num) = st2.Range(Prm(10) & r + Prm(8)).Value 'リストBの特定列の値を配列DataArr()へ代入
Exit Do
End If
If r > LastRow2 - Prm(8) Then 'リストBを全て検索しても一致する名称が見つからなかったら
Num = Num + 1
ReDim Preserve DataArr(0 To Num)
DataArr(Num) = "" '空の要素を代入
Exit Do
End If
r = r + 1
Loop
DoEvents
Next i
Debug.Print "途中経過３：" & Timer - startTime & "秒"
'リストAの特定列へ、リストBの特定列の値を書き込む
For i = 1 To LastRow1 - Prm(2)
st1.Range(Prm(4) & Prm(2) + i).Value = DataArr(i)
Next
Debug.Print "途中経過４：" & Timer - startTime & "秒"
'一時保管しておいた元の値を、リストAとリストBへ書き戻す
For Cnt = 1 To LastRow1 - Prm(2)
Data1(Cnt, 1) = Data1_temp(Cnt) '二次元配列Data1はRangeへの参照を記録しているため、Data1の値を書き換えればシートに反映される
Next
For Cnt = 1 To LastRow2 - Prm(8)
Data2(Cnt, 1) = Data2_temp(Cnt) '二次元配列Data2はRangeへの参照を記録しているため、Data2の値を書き換えればシートに反映される
Next
Debug.Print "計測を終了します"
Debug.Print "処理にかかった時間：" & Timer - startTime & "秒"
Erase DataArr()
Erase Data1_temp()
Erase Data2_temp()
Set Data1 = Nothing
Set Data2 = Nothing
Set st1 = Nothing
Set st2 = Nothing
'Set wb1 = Nothing
'Set wb2 = Nothing
End Subこっちは標準モジュールにコピペして下さい。
※同様に、VBEの標準モジュールを表示する方法は下図の通り。
これで準備完了です。
あとはExcelブックを開くだけで、ユーザーフォームが自動的に立ち上がるようになります。ユーザーフォームのテキストボックスには、予め適当な文字列をプリセットしてありますので、プリセットされた例に倣って適宜書き換えてください。
以下、VBAの内容補足です。
このマクロを自分好みにアレンジしたい人は、読んでください。
メイン処理部分の概要を改めて整理すると…
①ユーザーフォームから引数を受け取る。
引数Prm()はユーザーフォームの入力内容、Flagは検索オプションの有無。
②リストAのキー列全てを二次元配列Data1()へ格納。
検索オプションの有無に応じて、Data1()をReplace関数で丸ごと変換。
ここで日本語の表記揺れを吸収する。
③同じくリストBのキー列全てを二次元配列Data2()へ格納。
検索オプションの有無に応じて、Data2()をReplace関数で丸ごと変換。
ここで日本語の表記揺れを吸収する。
④Data1()から要素を１つづつ取り出し、Data2()の中で一致するものを確認。
一致するものがあれば、Data2()の当該行に相当する「リストBの特定列」
の値を、配列DataArr()へ代入。
一致するものがなければ、空の要素を配列DatArr()へ代入。
⑤Data1()の要素の数だけ、④の処理を繰り返す。
⑥処理結果である配列DataArr()を、リストAの特定列に書き込む。
となります。
ちなみに、検索オプションの有無に応じてReplace関数で二次元配列Data1()、Data2()を変換すると、シート上の値もそのまま置き換わってしまいます。
※Data1()、Data2()が値自体でなく、Rangeへの参照を記録している為。
シート上の値が置き換わってしまうと不都合が生じる（元データが勝手に変わってしまう）ため、これを防ぐために、一時避難用の配列Data1_temp()とData2_tempへそれぞれ元データをコピーしておき、最後にリストA・リストBに書き戻すという処理を加えています。
また冒頭紹介した自分好みの検索条件を追加したい場合は、メイン処理のReplace関数の部分を適宜カスタマイズしてください。
例えば「Data1(Cnt, 1) = Replace(Data1(Cnt, 1), "―", "ー", )」という処理では、ハイフン「―」を「ー」の表記に統一することで、ハイフンの表記揺れを吸収しています。これをData1()とData2()で実行することで、同じ条件でキー検索を掛けることが出来るためヒット率が上がるという訳です。
「Data1(Cnt, 1) = Replace(Data1(Cnt, 1), ChrW(&H2014), "ー")」であれば、環境文字の「—」（文字コード2014）を通常のハイフン「ー」へ変換します。このように環境文字の表記揺れも吸収可能。
どの文字をどう吸収させるのが良いかは、扱うリストによっても異なるでしょう。必要に応じて適宜カスタマイズしてみてください。
●補足
ここまでツラツラ書いておきながら何ですが、「単にリストを結合する」だけなら他のアプローチもありますよ、という事で一応紹介しておきます。
●冒頭紹介した画像の再掲
参考①：「VLOOKUP関数」を使ったリスト結合方法
Sub Sample()
Dim ListA As Worksheet
Dim ListB As Worksheet
Set ListA = Workbooks.Open(パス).Worksheets("リストA")
Set ListB = Workbooks.Open(パス).Worksheets("リストB")
sh1.Range("D3:D16").Value = Application.WorksheetFunction. _
VLookup(sh1.Range("B3:B16").Value, sh2.Range("A4:C12"), 2, False)
End Subワークシート関数の「VLOOKUP関数」を使った方法です。
お手軽に実装できますね。
というか、わざわざVBAで書く必要すらないかもです。
参考②：SQL（データベース接続）を使ったリスト結合方法
Sub Sample()
Dim Connection As Object
Dim RecordSet As Object
Dim SQL As String
'データベース接続＆レコードセット
Set Connection = CreateObject("ADODB.Connection")
Connection.Provider = "Microsoft.ACE.OLEDB.12.0"
Connection.Properties("Extended Properties") = "Excel 12.0 Macro" 'マクロ無ブックなら「Excel 12.0 Xml」
Connection.Open パス
Set RecordSet = CreateObject("ADODB.Recordset")
'SQL文を作成
SQL = "SELECT"
SQL = SQL & " リストA.出版社,"
SQL = SQL & " リストA.タイトル, "
SQL = SQL & " リストA.完結,"
SQL = SQL & " リストB.コメント"
SQL = SQL & " FROM"
SQL = SQL & " [リストA$] AS リストA"
SQL = SQL & " LEFT OUTER JOIN [リストB$] AS リストB"
SQL = SQL & " ON リストA.タイトル = リストB.タイトル"
'SQLに基づきデータ取得
RecordSet.Open SQL, Connection
'シート転記
Workbooks.Open(パス).Worksheets("リストA").Range("A2").CopyFromRecordset RecordSet
End SubExcelをデータベースとして扱う方法です。
メリットとして、大量のデータを高速で扱うことができます。数万件の膨大なデータをどうしてもExcel形式で扱わなければならない時は、この方法もアリ。
デメリットとしてSQL文での命令が必要なので、VBA言語と比べると馴染みが薄い人が多いでしょう。折角VBAマクロを作ってもノウハウが（自分だけに）属人化しがち。
なおデータベースとしてExcelファイルを扱う場合の作法として、データの見出しは1行目に記載し、データは１シートにつき１つとしておきます。
→結論
あとからVBAコードを見返したときに、どんな処理をやっているか一目で分かるような書き方が理想だと思いました。
あとから自分好みにカスタマイズする可能性があるなら尚更。
コードが多少冗長になっても、処理時間が伸びたとしても、個人的には今回ツラツラと紹介したマクロが一番使い勝手が良さそうに感じました。
この記事が気に入ったらサポートをしてみませんか？