Option Explicit
    Const K1 As String = "アクティオ"
    Const K2 As String = "クボタ建機"
    Const K3 As String = "コマツ"
    Dim dicK As Object
    Dim sh2 As Worksheet
Public Sub リース集計()
    Dim sh As Worksheet
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim row1 As Long
    Dim row1s As Long
    Dim row2 As Long
    Dim dicT As Object
    Dim key As Variant
    Dim kikan As Long   '期間
    Dim drow As Long    'データ表の行
    Dim dcol As Long    'データ表の列
    Dim mkikaku As Long '月極規格
    Dim mtanka As Long  '月割単価
    Dim dtanka As Long  '日割単価
    Dim hoshou As Long  '保証料
    Dim kihon As Long   '基本料
    Dim sho As Long     '商（期間を月極規格で割った商）
    Dim amari As Long   '余（期間を月極規格で割った余）
    Dim kingaku As Long '計算した金額
 
    Call データ表読込
    Set sh = Worksheets("リース")
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    sh.Activate
    maxrow1 = sh.Cells(Rows.Count, "B").End(xlUp).Row
    maxrow2 = sh.Cells(Rows.Count, "I").End(xlUp).Row
    If maxrow2 > 3 Then
        sh.Range("I4:M" & maxrow2).Value = ""
    End If
    row2 = 4
    For row1 = 4 To maxrow1
        '会社名チェック
        If dicK.exists(sh.Cells(row1, "B").Value) = False Then
            MsgBox (row1 & "行　会社名エラー:" & sh.Cells(row1, "B").Value)
            Exit Sub
        End If
        '開始日設定時
        If sh.Cells(row1, "D").Value <> "" Then
            key = sh.Cells(row1, "B").Value & "|" & sh.Cells(row1, "C").Value
            If dicT.exists(key) = True Then
                MsgBox ("開始日重複")
                sh.Cells(row1, "D").Select
                End
            End If
            dicT(key) = row1    '行番号記憶
        End If
        '返却日設定時
        If sh.Cells(row1, "E").Value <> "" Then
            key = sh.Cells(row1, "B").Value & "|" & sh.Cells(row1, "C").Value
            If dicT.exists(key) = False Then
                MsgBox ("開始日未設定")
                sh.Cells(row1, "E").Select
                End
            End If
            row1s = dicT(key)
            sh.Cells(row2, "I").Value = sh.Cells(row1s, "B").Value    'リース会社
            sh.Cells(row2, "J").Value = sh.Cells(row1s, "C").Value    '品目
            sh.Cells(row2, "K").Value = sh.Cells(row1s, "D").Value    '開始日
            sh.Cells(row2, "L").Value = sh.Cells(row1, "E").Value    '返却日
            sh.Cells(row2, "M").Value = sh.Cells(row2, "L").Value - sh.Cells(row2, "K").Value + 1    '期間
            '金額の算出
            '会社毎の品目を取得
            If dicK.exists(key) = True Then
                kikan = sh.Cells(row2, "M").Value           '期間
                drow = dicK(key) \ 10000                    'データ表の行
                dcol = dicK(key) Mod 10000                  'データ表の列
                mkikaku = sh2.Cells(drow, dcol + 1).Value   '月極規格
                mtanka = sh2.Cells(drow, dcol + 2).Value    '月割単価
                dtanka = sh2.Cells(drow, dcol + 3).Value    '日割単価
                hoshou = sh2.Cells(drow, dcol + 4).Value    '保証料
                kihon = sh2.Cells(drow, dcol + 5).Value     '基本料
                sho = kikan \ 30
                amari = kikan Mod 30
                If amari > mkikaku Then
                    sho = sho + 1
                    amari = amari - mkikaku
                End If
                kingaku = mtanka * sho + dtanka * amari + hoshou * kikan + kihon
                sh.Cells(row2, "N").Value = kingaku
            Else
                sh.Cells(row2, "N").Value = "品目なし"
            End If
            row2 = row2 + 1
            dicT.Remove (key)
        End If
    Next
    For Each key In dicT
        row1 = dicT(key)
        MsgBox ("返却日なし " & "行=" & row1 & " リース会社・品目=" & key & " 開始日=" & sh.Cells(row1, "D").Value)
    Next
    MsgBox ("集計完了")
End Sub
 
 
Private Sub データ表読込()
    Dim drow As Long
    Dim hin1 As String
    Dim hin2 As String
    Dim hin3 As String
    Dim key As String
    Set sh2 = Worksheets("データ表")
    Set dicK = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    dicK(K1) = True
    dicK(K2) = True
    dicK(K3) = True
    For drow = 112 To 147
        hin1 = sh2.Cells(drow, "B").Value
        hin2 = sh2.Cells(drow, "H").Value
        hin3 = sh2.Cells(drow, "N").Value
        '品目の行と列を記憶
        If hin1 <> "" Then
            key = K1 & "|" & hin1
            dicK(key) = drow * 10000 + 2
        End If
        If hin2 <> "" Then
            key = K2 & "|" & hin2
            dicK(key) = drow * 10000 + 8
        End If
        If hin3 <> "" Then
            key = K3 & "|" & hin3
            dicK(key) = drow * 10000 + 14
        End If
    Next
End Sub
 

T3B0aW9uIEV4cGxpY2l0CiAgICBDb25zdCBLMSBBcyBTdHJpbmcgPSAi44Ki44Kv44OG44Kj44KqIgogICAgQ29uc3QgSzIgQXMgU3RyaW5nID0gIuOCr+ODnOOCv+W7uuapnyIKICAgIENvbnN0IEszIEFzIFN0cmluZyA9ICLjgrPjg57jg4QiCiAgICBEaW0gZGljSyBBcyBPYmplY3QKICAgIERpbSBzaDIgQXMgV29ya3NoZWV0ClB1YmxpYyBTdWIg44Oq44O844K56ZuG6KiIKCkKICAgIERpbSBzaCBBcyBXb3Jrc2hlZXQKICAgIERpbSBtYXhyb3cxIEFzIExvbmcKICAgIERpbSBtYXhyb3cyIEFzIExvbmcKICAgIERpbSByb3cxIEFzIExvbmcKICAgIERpbSByb3cxcyBBcyBMb25nCiAgICBEaW0gcm93MiBBcyBMb25nCiAgICBEaW0gZGljVCBBcyBPYmplY3QKICAgIERpbSBrZXkgQXMgVmFyaWFudAogICAgRGltIGtpa2FuIEFzIExvbmcgICAn5pyf6ZaTCiAgICBEaW0gZHJvdyBBcyBMb25nICAgICfjg4fjg7zjgr/ooajjga7ooYwKICAgIERpbSBkY29sIEFzIExvbmcgICAgJ+ODh+ODvOOCv+ihqOOBruWIlwogICAgRGltIG1raWtha3UgQXMgTG9uZyAn5pyI5qW16KaP5qC8CiAgICBEaW0gbXRhbmthIEFzIExvbmcgICfmnIjlibLljZjkvqEKICAgIERpbSBkdGFua2EgQXMgTG9uZyAgJ+aXpeWJsuWNmOS+oQogICAgRGltIGhvc2hvdSBBcyBMb25nICAn5L+d6Ki85paZCiAgICBEaW0ga2lob24gQXMgTG9uZyAgICfln7rmnKzmlpkKICAgIERpbSBzaG8gQXMgTG9uZyAgICAgJ+WVhu+8iOacn+mWk+OCkuaciOalteimj+agvOOBp+WJsuOBo+OBn+WVhu+8iQogICAgRGltIGFtYXJpIEFzIExvbmcgICAn5L2Z77yI5pyf6ZaT44KS5pyI5qW16KaP5qC844Gn5Ymy44Gj44Gf5L2Z77yJCiAgICBEaW0ga2luZ2FrdSBBcyBMb25nICfoqIjnrpfjgZfjgZ/ph5HpoY0KICAgIAogICAgQ2FsbCDjg4fjg7zjgr/ooajoqq3ovrwKICAgIFNldCBzaCA9IFdvcmtzaGVldHMoIuODquODvOOCuSIpCiAgICBTZXQgZGljVCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAgICAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgc2guQWN0aXZhdGUKICAgIG1heHJvdzEgPSBzaC5DZWxscyhSb3dzLkNvdW50LCAiQiIpLkVuZCh4bFVwKS5Sb3cKICAgIG1heHJvdzIgPSBzaC5DZWxscyhSb3dzLkNvdW50LCAiSSIpLkVuZCh4bFVwKS5Sb3cKICAgIElmIG1heHJvdzIgPiAzIFRoZW4KICAgICAgICBzaC5SYW5nZSgiSTQ6TSIgJiBtYXhyb3cyKS5WYWx1ZSA9ICIiCiAgICBFbmQgSWYKICAgIHJvdzIgPSA0CiAgICBGb3Igcm93MSA9IDQgVG8gbWF4cm93MQogICAgICAgICfkvJrnpL7lkI3jg4Hjgqfjg4Pjgq8KICAgICAgICBJZiBkaWNLLmV4aXN0cyhzaC5DZWxscyhyb3cxLCAiQiIpLlZhbHVlKSA9IEZhbHNlIFRoZW4KICAgICAgICAgICAgTXNnQm94IChyb3cxICYgIuihjOOAgOS8muekvuWQjeOCqOODqeODvDoiICYgc2guQ2VsbHMocm93MSwgIkIiKS5WYWx1ZSkKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICAn6ZaL5aeL5pel6Kit5a6a5pmCCiAgICAgICAgSWYgc2guQ2VsbHMocm93MSwgIkQiKS5WYWx1ZSA8PiAiIiBUaGVuCiAgICAgICAgICAgIGtleSA9IHNoLkNlbGxzKHJvdzEsICJCIikuVmFsdWUgJiAifCIgJiBzaC5DZWxscyhyb3cxLCAiQyIpLlZhbHVlCiAgICAgICAgICAgIElmIGRpY1QuZXhpc3RzKGtleSkgPSBUcnVlIFRoZW4KICAgICAgICAgICAgICAgIE1zZ0JveCAoIumWi+Wni+aXpemHjeikhyIpCiAgICAgICAgICAgICAgICBzaC5DZWxscyhyb3cxLCAiRCIpLlNlbGVjdAogICAgICAgICAgICAgICAgRW5kCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICBkaWNUKGtleSkgPSByb3cxICAgICfooYznlarlj7foqJjmhrYKICAgICAgICBFbmQgSWYKICAgICAgICAn6L+U5Y205pel6Kit5a6a5pmCCiAgICAgICAgSWYgc2guQ2VsbHMocm93MSwgIkUiKS5WYWx1ZSA8PiAiIiBUaGVuCiAgICAgICAgICAgIGtleSA9IHNoLkNlbGxzKHJvdzEsICJCIikuVmFsdWUgJiAifCIgJiBzaC5DZWxscyhyb3cxLCAiQyIpLlZhbHVlCiAgICAgICAgICAgIElmIGRpY1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgICAgICBNc2dCb3ggKCLplovlp4vml6XmnKroqK3lrpoiKQogICAgICAgICAgICAgICAgc2guQ2VsbHMocm93MSwgIkUiKS5TZWxlY3QKICAgICAgICAgICAgICAgIEVuZAogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgcm93MXMgPSBkaWNUKGtleSkKICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIkkiKS5WYWx1ZSA9IHNoLkNlbGxzKHJvdzFzLCAiQiIpLlZhbHVlICAgICfjg6rjg7zjgrnkvJrnpL4KICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIkoiKS5WYWx1ZSA9IHNoLkNlbGxzKHJvdzFzLCAiQyIpLlZhbHVlICAgICflk4Hnm64KICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIksiKS5WYWx1ZSA9IHNoLkNlbGxzKHJvdzFzLCAiRCIpLlZhbHVlICAgICfplovlp4vml6UKICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIkwiKS5WYWx1ZSA9IHNoLkNlbGxzKHJvdzEsICJFIikuVmFsdWUgICAgJ+i/lOWNtOaXpQogICAgICAgICAgICBzaC5DZWxscyhyb3cyLCAiTSIpLlZhbHVlID0gc2guQ2VsbHMocm93MiwgIkwiKS5WYWx1ZSAtIHNoLkNlbGxzKHJvdzIsICJLIikuVmFsdWUgKyAxICAgICfmnJ/plpMKICAgICAgICAgICAgJ+mHkemhjeOBrueul+WHugogICAgICAgICAgICAn5Lya56S+5q+O44Gu5ZOB55uu44KS5Y+W5b6XCiAgICAgICAgICAgIElmIGRpY0suZXhpc3RzKGtleSkgPSBUcnVlIFRoZW4KICAgICAgICAgICAgICAgIGtpa2FuID0gc2guQ2VsbHMocm93MiwgIk0iKS5WYWx1ZSAgICAgICAgICAgJ+acn+mWkwogICAgICAgICAgICAgICAgZHJvdyA9IGRpY0soa2V5KSBcIDEwMDAwICAgICAgICAgICAgICAgICAgICAn44OH44O844K/6KGo44Gu6KGMCiAgICAgICAgICAgICAgICBkY29sID0gZGljSyhrZXkpIE1vZCAxMDAwMCAgICAgICAgICAgICAgICAgICfjg4fjg7zjgr/ooajjga7liJcKICAgICAgICAgICAgICAgIG1raWtha3UgPSBzaDIuQ2VsbHMoZHJvdywgZGNvbCArIDEpLlZhbHVlICAgJ+aciOalteimj+agvAogICAgICAgICAgICAgICAgbXRhbmthID0gc2gyLkNlbGxzKGRyb3csIGRjb2wgKyAyKS5WYWx1ZSAgICAn5pyI5Ymy5Y2Y5L6hCiAgICAgICAgICAgICAgICBkdGFua2EgPSBzaDIuQ2VsbHMoZHJvdywgZGNvbCArIDMpLlZhbHVlICAgICfml6XlibLljZjkvqEKICAgICAgICAgICAgICAgIGhvc2hvdSA9IHNoMi5DZWxscyhkcm93LCBkY29sICsgNCkuVmFsdWUgICAgJ+S/neiovOaWmQogICAgICAgICAgICAgICAga2lob24gPSBzaDIuQ2VsbHMoZHJvdywgZGNvbCArIDUpLlZhbHVlICAgICAn5Z+65pys5paZCiAgICAgICAgICAgICAgICBzaG8gPSBraWthbiBcIDMwCiAgICAgICAgICAgICAgICBhbWFyaSA9IGtpa2FuIE1vZCAzMAogICAgICAgICAgICAgICAgSWYgYW1hcmkgPiBta2lrYWt1IFRoZW4KICAgICAgICAgICAgICAgICAgICBzaG8gPSBzaG8gKyAxCiAgICAgICAgICAgICAgICAgICAgYW1hcmkgPSBhbWFyaSAtIG1raWtha3UKICAgICAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICAgICAga2luZ2FrdSA9IG10YW5rYSAqIHNobyArIGR0YW5rYSAqIGFtYXJpICsgaG9zaG91ICoga2lrYW4gKyBraWhvbgogICAgICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIk4iKS5WYWx1ZSA9IGtpbmdha3UKICAgICAgICAgICAgRWxzZQogICAgICAgICAgICAgICAgc2guQ2VsbHMocm93MiwgIk4iKS5WYWx1ZSA9ICLlk4Hnm67jgarjgZciCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICByb3cyID0gcm93MiArIDEKICAgICAgICAgICAgZGljVC5SZW1vdmUgKGtleSkKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgIEZvciBFYWNoIGtleSBJbiBkaWNUCiAgICAgICAgcm93MSA9IGRpY1Qoa2V5KQogICAgICAgIE1zZ0JveCAoIui/lOWNtOaXpeOBquOBlyAiICYgIuihjD0iICYgcm93MSAmICIg44Oq44O844K55Lya56S+44O75ZOB55uuPSIgJiBrZXkgJiAiIOmWi+Wni+aXpT0iICYgc2guQ2VsbHMocm93MSwgIkQiKS5WYWx1ZSkKICAgIE5leHQKICAgIE1zZ0JveCAoIumbhuioiOWujOS6hiIpCkVuZCBTdWIKCgpQcml2YXRlIFN1YiDjg4fjg7zjgr/ooajoqq3ovrwoKQogICAgRGltIGRyb3cgQXMgTG9uZwogICAgRGltIGhpbjEgQXMgU3RyaW5nCiAgICBEaW0gaGluMiBBcyBTdHJpbmcKICAgIERpbSBoaW4zIEFzIFN0cmluZwogICAgRGltIGtleSBBcyBTdHJpbmcKICAgIFNldCBzaDIgPSBXb3Jrc2hlZXRzKCLjg4fjg7zjgr/ooagiKQogICAgU2V0IGRpY0sgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgICAgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgIGRpY0soSzEpID0gVHJ1ZQogICAgZGljSyhLMikgPSBUcnVlCiAgICBkaWNLKEszKSA9IFRydWUKICAgIEZvciBkcm93ID0gMTEyIFRvIDE0NwogICAgICAgIGhpbjEgPSBzaDIuQ2VsbHMoZHJvdywgIkIiKS5WYWx1ZQogICAgICAgIGhpbjIgPSBzaDIuQ2VsbHMoZHJvdywgIkgiKS5WYWx1ZQogICAgICAgIGhpbjMgPSBzaDIuQ2VsbHMoZHJvdywgIk4iKS5WYWx1ZQogICAgICAgICflk4Hnm67jga7ooYzjgajliJfjgpLoqJjmhrYKICAgICAgICBJZiBoaW4xIDw+ICIiIFRoZW4KICAgICAgICAgICAga2V5ID0gSzEgJiAifCIgJiBoaW4xCiAgICAgICAgICAgIGRpY0soa2V5KSA9IGRyb3cgKiAxMDAwMCArIDIKICAgICAgICBFbmQgSWYKICAgICAgICBJZiBoaW4yIDw+ICIiIFRoZW4KICAgICAgICAgICAga2V5ID0gSzIgJiAifCIgJiBoaW4yCiAgICAgICAgICAgIGRpY0soa2V5KSA9IGRyb3cgKiAxMDAwMCArIDgKICAgICAgICBFbmQgSWYKICAgICAgICBJZiBoaW4zIDw+ICIiIFRoZW4KICAgICAgICAgICAga2V5ID0gSzMgJiAifCIgJiBoaW4zCiAgICAgICAgICAgIGRpY0soa2V5KSA9IGRyb3cgKiAxMDAwMCArIDE0CiAgICAgICAgRW5kIElmCiAgICBOZXh0CkVuZCBTdWIK