ソース
標準モジュール
Option Explicit
Global UFflg As Boolean
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
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
