Excelで取引先表を作ってみよう

'取引先IDが登録されているかチェック
Private Function ExCopyToSheetCheck(id As Long, ByRef srow As String) As Boolean
    Dim lrow As Long
    Dim tRange As Range
    Dim s As String
    
    srow = ""
    ExCopyToSheetCheck = False
    s = ""
    
    lrow = Sheets("T取引先").Range("A65536").End(xlUp).Row
        
    If lrow = 4 Then
        srow = "A5"
    Else
        Set tRange = Sheets("T取引先"). _
            Range("A8", Sheets("T取引先").Range("A5").Offset(rowOffset:=lrow)). _
            Find(What:=id, LookIn:=xlValues) '
        If Not tRange Is Nothing Then
            srow = tRange.Address
            ExCopyToSheetCheck = True
        Else
            srow = "A" & lrow + 1
        End If
    End If
End Function

'指定範囲から最大値を検索
Private Function ExFindMax(ByRef srow As String) As Boolean
    Dim ans As Long
    Dim tRange As Range
    
    ExFindMax = False
    '1列目の最大値を捜す
    Set tRange = Sheets("T取引先").Columns(1)
    ans = Application.WorksheetFunction.Max(tRange)
    
    '最大値のセルを取得
    Set tRange = tRange.Find(What:=ans, LookIn:=xlValues, LookAt:=xlWhole)
    If Not tRange Is Nothing Then
        srow = tRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        ExFindMax = True
    End If
End Function

'指定範囲から最小値を検索
Private Function ExFindMin(ByRef srow As String) As Boolean
    Dim ans As Long
    Dim tRange As Range
    
    ExFindMin = False
    '1列目の最小値を捜す
    Set tRange = Sheets("T取引先").Columns(1)
    ans = Application.WorksheetFunction.Min(tRange)
    
    '最小値のセルを取得
    Set tRange = tRange.Find(What:=ans, LookIn:=xlValues, LookAt:=xlWhole)
    If Not tRange Is Nothing Then
        srow = tRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        ExFindMin = True
    End If
End Function


'T取引先からメインへコピー
Private Sub ExDataDisp(srow As String)
    Dim i As Integer
    Dim scell As String
    
    'IDコピー
    Range("D3") = Sheets("T取引先").Range(srow)
    '前、次ボタン用のセル位置
    Sheets("T取引先").Range("CR5") = "<=" & Range("D3")
    Sheets("T取引先").Range("CR6") = ">=" & Range("D3")
    
    For i = 1 To 11
        Select Case i
            Case 1: scell = "D4:G4"
            Case 2: scell = "D5:F5"
            Case 3: scell = "D6:E6"
            Case 4: scell = "D7:J7"
            Case 5: scell = "D8:F8"
            Case 6: scell = "D9:F9"
            Case 7: scell = "D10:F10"
            Case 8: scell = "D11:F11"
            Case 9: scell = "D12:J12"
            Case 10: scell = "D13:J13"
            Case 11: scell = "D14:J16"
        End Select
        
        'コピー
        Sheets("T取引先").Range(srow).Offset(0, i).Copy Destination:=Range(scell)
    Next
    bDataChangeFlag = False
End Sub

'先頭のレコード
Private Sub CommandButton3_Click()
    Dim sr As String
    
    If ExFindMin(sr) Then
        If ExDataChangeMsg = False Then
            Exit Sub
        End If
        
        ExDataDisp sr
    Else
        Beep
    End If
End Sub

'前のレコード
Private Sub CommandButton4_Click()
    Dim sr As String
    
    If Range("D3") = "" Then
        CommandButton6_Click
    Else
        If IsNumeric(Sheets("T取引先").Range("CT9")) Then
            If ExDataChangeMsg = False Then
                Exit Sub
            End If
            
            ExCopyToSheetCheck Sheets("T取引先").Range("CT9"), sr
            ExDataDisp sr
        Else
            Beep
        End If
    End If
End Sub

'次のレコード
Private Sub CommandButton5_Click()
    Dim sr As String
    
    If Range("D3") = "" Then
        CommandButton3_Click
    Else
        If IsNumeric(Sheets("T取引先").Range("CT8")) Then
            If ExDataChangeMsg = False Then
                Exit Sub
            End If
            
            ExCopyToSheetCheck Sheets("T取引先").Range("CT8"), sr
            ExDataDisp sr
        Else
            Beep
        End If
    End If
End Sub

'最終レコード
Private Sub CommandButton6_Click()
    Dim sr As String
    
    If ExFindMax(sr) Then
        If ExDataChangeMsg = False Then
            Exit Sub
        End If
    
        ExDataDisp sr
    Else
        Beep
    End If
End Sub