名簿と商品管理とかなんかそういうの

エルベさんったらまたお仕事の情報漏洩？　と思った皆様こんにちはこんにちは。
今日は2つのテーブルから1つのテーブルを生成する時に楽になる入力シートを作ろう、です。はい。職場（ネットにつながらない）で作ったので・・・一応、用途を変えたのであまり意味なく見えるかも(；´Д｀)
 

疑似個人情報データ生成サービス
で作成したデータ使いまわしております（笑）ありがたやぁ～🙏
IDはハッシュ生成使ってみました。うん、わかってない（笑）

前提

こんな感じで管理してる商品があるとしまする～。

出納帳の黄色いセルは数式が入っていまする。

準備

全部テーブル化してお名前つけておきまする。
入力シート追加
ユーザーフォーム1つ挿入
ListViewを↑に貼り付けまする。
 
入力シートはこんな感じに（購入日と対応者は自動で入るようにするので空欄でＯＫ）
コンボボックス1つ、コマンドボタン2つ使います。

 
ユーザーフォーム

ソース

標準モジュール

Option Explicit
'ユーザーフォームの表示制御用
Global UFflg As Boolean

'https://blog.nekonium.com/vba-hash/
Public Function MD5_HEX(str As String) As String
    Dim md5 As Object
    Dim utf8 As Object
    Dim bytes() As Byte
    Dim hash() As Byte
    Dim i As Integer
    Dim res As String

    Set utf8 = CreateObject("System.Text.UTF8Encoding")
    bytes = utf8.GetBytes_4(str)

    Set md5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    hash = md5.ComputeHash_2(bytes)

    For i = LBound(hash) To UBound(hash)
        res = res & LCase(Right("0" & Hex(hash(i)), 2))
    Next i

    MD5_HEX = LCase(res)
End Function

Sub クリアボタン()
    Sheet4.初期設定
End Sub

Sub 登録ボタン()
    Dim str As String
    str = Sheet4.chkParameter()
    If str = "" Then
        Dim pa
        pa = WorksheetFunction.Transpose(Range("B2:B8"))
        Sheet3.addListO pa
        Sheet4.初期設定
    Else
        MsgBox str
    End If
End Sub

sheet1（顧客情報）

Option Explicit
'フィルターを掛けてユーザーフォームにデータ追加
Sub filterListO(p1, p2, p3)
    Dim l As ListObject: Set l = Me.ListObjects("メンバーリスト")
    If Me.FilterMode Then Me.ShowAllData
    If p1 <> "" Then l.Range.AutoFilter 1, "*" & p1 & "*"
    If p2 <> "" Then l.Range.AutoFilter 2, "*" & p2 & "*"
    If p3 <> "" Then l.Range.AutoFilter 3, "*" & p3 & "*"
    
    If l.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
        Dim r As Range
        For Each r In l.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible)
            UserForm1.setListView r(1), r(1).Offset(0, 1), r(1).Offset(0, 2)
        Next
        If UFflg Then UserForm1.Show
    Else
        If Me.FilterMode Then Me.ShowAllData
    End If
    
End Sub

sheet2（商品リスト）

Option Explicit
'与えられた日より前の商品の文字列配列
Function filterDate(d As Date) As String()
    Dim lo As ListObject: Set lo = Me.ListObjects("商品リスト")
    lo.Range.AutoFilter 2, "<=" & d
    Dim r: Set r = lo.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible)
    ReDim ret(r.Count) As String
    Dim i As Integer
    For i = 1 To r.Count
        ret(i) = r.Cells(i) & "_" & r.Cells(i).Offset(0, 2)
    Next
    If lo.Range.AutoFilter Then lo.Range.AutoFilter
    filterDate = ret
End Function

sheet3（出納帳）

Option Explicit
'データ追加
Sub addListO(p)
    Dim l As ListObject: Set l = Me.ListObjects("出納帳")
    Dim lr As ListRow: Set lr = l.ListRows.Add
    lr.Range(1) = p(4)
    Dim pp
    pp = Split(p(2), "_")
    lr.Range(4) = pp(0)
    lr.Range(5) = pp(1)
    
    lr.Range(7) = p(1)
    lr.Range(8) = p(3)
    lr.Range(10) = p(7)
    
End Sub

sheet4（入力シート）

Option Explicit
Sub 初期設定()
    Range("B2:B8").ClearContents
    Range("B2") = Date
    Range("B8") = Application.UserName
    Dim prdct: prdct = Sheet2.filterDate(Date)
    Dim i As Integer
    Me.ComboBox1.Clear
    For i = 1 To UBound(prdct)
        Me.ComboBox1.AddItem prdct(i)
    Next
    UFflg = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim re: Set re = Intersect(Range("B5:B7"), Target)
    If Not re Is Nothing And UFflg Then
            '顧客情報入力値が変わったらフィルターかけてユーザーフォーム表示
            If Range("B5").Text <> "" Or Range("B6").Text <> "" Or Range("B7").Text <> "" Then
                Sheet1.filterListO Range("B5"), Range("B6"), Range("B7")
            End If
    Else
        If Sheet1.FilterMode Then Sheet1.ShowAllData
    End If
End Sub
'顧客情報設定
Sub setKey(p1, p2, p3)
    Range("B5") = p1
    Range("B6") = p2
    Range("B7") = p3
End Sub
'入力値チェック
Function chkParameter() As String
    Dim str: str = Array("購入日", "商品名", "個数", "ID", "氏名", "氏名（カタカナ）", "対応者")
    Dim i As Integer
    Dim re As String
    For i = 0 To UBound(str)
        If Cells(i + 2, 2) = "" Then
            re = re & str(i) & " が空欄です。" + vbCrLf
        End If
    Next
    chkParameter = re
End Function

ユーザーフォーム

Option Explicit
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
    UFflg = False
    Sheet4.setKey Item, Item.ListSubItems(1), Item.ListSubItems(2)
    UFflg = True
    Me.ListView1.ListItems.Clear
    Me.Hide
End Sub
'http://officetanaka.net/excel/vba/listview/03.htm
Private Sub UserForm_Initialize()
    Me.Caption = "メンバーリスト"
    With ListView1
        .View = lvwReport           ''表示
        .LabelEdit = lvwManual      ''ラベルの編集
        .HideSelection = False      ''選択の自動解除
        .AllowColumnReorder = True  ''列幅の変更を許可
        .FullRowSelect = True       ''行全体を選択
        .Gridlines = True           ''グリッド線
        
        .ColumnHeaders.Add , , "ID"
        .ColumnHeaders.Add , , "名前"
        .ColumnHeaders.Add , , "ヨミガナ"
    End With
End Sub
Sub setListView(p1, p2, p3)
    If p1 <> "" And p2 <> "" And p3 <> "" Then
        With ListView1.ListItems.Add
            .Text = p1
            .SubItems(1) = p2
            .SubItems(2) = p3
        End With
    Else
        UserForm1.Hide
        Unload UserForm1
    End If
End Sub

ThisWorkbook

Option Explicit
'ファイル開いた時入力シートの日付とかいれる
Private Sub Workbook_Open()
    Sheet4.Select
    Sheet4.初期設定
    UFflg = True
End Sub

実行イメージ

コレで入力シートのＩＤ、氏名、カナを入力すると候補が表示されるので選択できるようになります。
例えばIDに2が入ってて氏名にモモが入っている人・・・
2を入力して出てくるユーザーフォームをバツで閉じて、ヨミにモモを入れると・・・

クリックすると正式な情報が埋まりますヽ(=´▽`=)ﾉ

便利便利。

参考

Office TANAKA - ListViewコントロールの使い方[ListViewコントロールの操作]
【VBA】Excelでハッシュ関数を使う【SHA-256】【MD5】 | ネコニウム研究所
AutoFilter オブジェクト (Excel) | Microsoft Docs
ListRows.Add メソッド (Excel) | Microsoft Docs
三つ以上の部分一致条件で絞り込みを行う（オートフィルター不使用） - VBAの勉強を始めてみた
VBAで配列を引数・戻り値にする方法 - Qiita
【EXCEL VBA】オートフィルタで複数列を指定したい | EXCEL VBA 研究所（入門）
ExcelVBAでオートフィルタで絞り込んだデータの行数をカウントする - えくせるちゅんちゅん
フォームを閉じる - フォーム - Excelフォーム