Option Explicit
Dim wks As Worksheet    '設定対象シート
Dim jks As Worksheet    '条件シート
Dim ids As Worksheet    'IDシート
Dim dicT As Object      '連想配列　キー：支店＋拠点＋担当者　値：G列の担当者主担当部門コード
Public Sub ポイント付与()
    Dim sname As String     '対象シート名
    Set jks = Worksheets("★条件")
    Set ids = Worksheets("★ID")
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    '対象シート取得
    sname = jks.Range("J2").Value
    If get_sheet(sname, wks) = False Then
        MsgBox ("シート名不正<" & sname & ">")
        Exit Sub
    End If
    Call setup_tanid   '★IDシートを読み込み連想配列を作成する
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    'ポイント作成開始
    Call add_point("F2", "P3", "B", "F", "G", "I", "J")    'J列のポイント
    Call add_point("F2", "P3", "B", "L", "M", "O", "P")    'P列のポイント
    '以下ここに追加してください
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox ("完了")
End Sub
 
'P1: 主担当部門のセル位置 (ポイント取得用)
'P2: 担当者主担当部門のセル位置
'P3: 部門（拠点＋部署＋担当者）の開始列
'P4: 計画列
'P5: 実績列
'P6：達成／未達成列
'P7: ポイント付与列
Private Sub add_point(mainbm_cell As String, tanbm_cell As String, bumon_col As String, kei_col As String, jis_col As String, tas_col As String, point_col As String)
    Dim maxrow As Long
    Dim wrow As Long
    Dim mpoint As Variant       '満額ポイント
    Dim mainbm_val As Variant   '主担当部門
    Dim point As Long       '開始point
    Dim ap As Double        'point
    Dim bumon_colNo As Long '部門（拠点）の列番号
    Dim tan_id As String    '担当ID（課別）若しくは担当者主担当部門コード
    Dim idrow As Long       '★IDの行番号
    Dim key As Variant
    bumon_colNo = Range(bumon_col & "1").Column
    'ポイント取得
    mainbm_val = wks.Range(mainbm_cell)
    mpoint = Application.HLookup(mainbm_val, jks.Range("B19:D21"), 3, 0)
    If IsError(mpoint) Then
        MsgBox ("★条件シートのポイント取得エラー：主担当部門<" & mainbm_val & ">")
        MsgBox ("算出ポイント列=" & point_col)
        Application.Calculation = xlCalculationAutomatic
        End
    End If
    point = mpoint
    maxrow = wks.Cells(Rows.Count, "A").End(xlUp).Row             'A列最終行
    wks.Range(point_col & "5:" & point_col & maxrow).Value = 0    'ポイント行を０クリア
    For wrow = 5 To maxrow
        '部門（拠点）なしなら終了
        If wks.Cells(wrow, bumon_col) = "" Then Exit For
        '該当行の担当者主担当部門コードを取得する
        key = wks.Cells(wrow, bumon_colNo) & "|" & wks.Cells(wrow, bumon_colNo + 1) & "|" & wks.Cells(wrow, bumon_colNo + 2)
        If dicT.exists(key) = False Then
            MsgBox ("★IDシートに未登録<" & key & ">")
            MsgBox ("行番号=" & wrow & " 部門（拠点）列=" & bumon_col & " 算出ポイント列=" & point_col)
            ap = 0
        Else
            tan_id = dicT(key)
            '該当行のポイントを取得する
            ap = get_point(wrow, tanbm_cell, tan_id, kei_col, jis_col, tas_col, point)
        End If
        wks.Cells(wrow, point_col).Value = ap
        '付与ポイントがあるなら、ポイントから１引く
        If ap <> 0 Then
            point = point - 1
        End If
    Next
End Sub
'シート名取得
Private Function get_sheet(sname As String, ws As Worksheet)
    On Error GoTo ERR99
    Set ws = Worksheets(sname)
    get_sheet = True
    Exit Function
ERR99:
    get_sheet = False
End Function
'担当IDセットアップ
Private Sub setup_tanid()
    Dim maxrow As Long
    Dim wrow As Long
    Dim key As Variant
    maxrow = ids.Cells(Rows.Count, "A").End(xlUp).Row             'A列最終行
    For wrow = 3 To maxrow
        key = ids.Cells(wrow, "B").Value & "|" & ids.Cells(wrow, "C").Value & "|" & ids.Cells(wrow, "D").Value
        dicT(key) = ids.Cells(wrow, "G").Value
    Next
End Sub
'付与ポイント取得
Private Function get_point(wrow As Long, tanbm_cell As String, tan_id As String, kei_col As String, jis_col As String, tas_col As String, point As Long)
    Dim kei_val As Variant  '計画
    Dim jis_val As Variant  '実績
    Dim tas_val As Variant  '達成／未達成
    Dim rate As Double      'ポイントレート％
    get_point = 0
    rate = 0
    kei_val = wks.Cells(wrow, kei_col)
    jis_val = wks.Cells(wrow, jis_col)
    tas_val = wks.Cells(wrow, tas_col)
    If kei_val <= 0 And jis_val <= 0 Then Exit Function
    If wks.Range(tanbm_cell).Value = tan_id Then
        '担当者主担当部門と担当IDが一致
        If tas_val > 0 Then
            '達成／未達成＞０
            If kei_val >= 0 And jis_val > 0 Then rate = 100
        End If
        If tas_val < 0 Then
            '達成／未達成＜０
            If kei_val > 0 Then rate = 75
        End If
    Else
        '担当者主担当部門と担当IDが不一致
        If tas_val > 0 Then
            '達成／未達成＞０
            If kei_val = 0 And jis_val > 0 Then rate = 12.5
            If kei_val > 0 And jis_val > 0 Then rate = 25
        End If
    End If
    get_point = point * rate / 100
End Function
 

T3B0aW9uIEV4cGxpY2l0CkRpbSB3a3MgQXMgV29ya3NoZWV0ICAgICfoqK3lrprlr77osaHjgrfjg7zjg4gKRGltIGprcyBBcyBXb3Jrc2hlZXQgICAgJ+adoeS7tuOCt+ODvOODiApEaW0gaWRzIEFzIFdvcmtzaGVldCAgICAnSUTjgrfjg7zjg4gKRGltIGRpY1QgQXMgT2JqZWN0ICAgICAgJ+mAo+aDs+mFjeWIl+OAgOOCreODvO+8muaUr+W6l++8i+aLoOeCue+8i+aLheW9k+iAheOAgOWApO+8mkfliJfjga7mi4XlvZPogIXkuLvmi4XlvZPpg6jploDjgrPjg7zjg4kKUHVibGljIFN1YiDjg53jgqTjg7Pjg4jku5jkuI4oKQogICAgRGltIHNuYW1lIEFzIFN0cmluZyAgICAgJ+WvvuixoeOCt+ODvOODiOWQjQogICAgU2V0IGprcyA9IFdvcmtzaGVldHMoIuKYheadoeS7tiIpCiAgICBTZXQgaWRzID0gV29ya3NoZWV0cygi4piFSUQiKQogICAgU2V0IGRpY1QgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgICflr77osaHjgrfjg7zjg4jlj5blvpcKICAgIHNuYW1lID0gamtzLlJhbmdlKCJKMiIpLlZhbHVlCiAgICBJZiBnZXRfc2hlZXQoc25hbWUsIHdrcykgPSBGYWxzZSBUaGVuCiAgICAgICAgTXNnQm94ICgi44K344O844OI5ZCN5LiN5q2jPCIgJiBzbmFtZSAmICI+IikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICBDYWxsIHNldHVwX3RhbmlkICAgJ+KYhUlE44K344O844OI44KS6Kqt44G/6L6844G/6YCj5oOz6YWN5YiX44KS5L2c5oiQ44GZ44KLCiAgICBBcHBsaWNhdGlvbi5TY3JlZW5VcGRhdGluZyA9IEZhbHNlCiAgICBBcHBsaWNhdGlvbi5DYWxjdWxhdGlvbiA9IHhsQ2FsY3VsYXRpb25NYW51YWwKICAgICfjg53jgqTjg7Pjg4jkvZzmiJDplovlp4sKICAgIENhbGwgYWRkX3BvaW50KCJGMiIsICJQMyIsICJCIiwgIkYiLCAiRyIsICJJIiwgIkoiKSAgICAnSuWIl+OBruODneOCpOODs+ODiAogICAgQ2FsbCBhZGRfcG9pbnQoIkYyIiwgIlAzIiwgIkIiLCAiTCIsICJNIiwgIk8iLCAiUCIpICAgICdQ5YiX44Gu44Od44Kk44Oz44OICiAgICAn5Lul5LiL44GT44GT44Gr6L+95Yqg44GX44Gm44GP44Gg44GV44GECiAgICAKICAgIEFwcGxpY2F0aW9uLkNhbGN1bGF0aW9uID0geGxDYWxjdWxhdGlvbkF1dG9tYXRpYwogICAgQXBwbGljYXRpb24uU2NyZWVuVXBkYXRpbmcgPSBUcnVlCiAgICBNc2dCb3ggKCLlrozkuoYiKQpFbmQgU3ViCgonUDE6IOS4u+aLheW9k+mDqOmWgOOBruOCu+ODq+S9jee9riAo44Od44Kk44Oz44OI5Y+W5b6X55SoKQonUDI6IOaLheW9k+iAheS4u+aLheW9k+mDqOmWgOOBruOCu+ODq+S9jee9rgonUDM6IOmDqOmWgO+8iOaLoOeCue+8i+mDqOe9su+8i+aLheW9k+iAhe+8ieOBrumWi+Wni+WIlwonUDQ6IOioiOeUu+WIlwonUDU6IOWun+e4vuWIlwonUDbvvJrpgZTmiJDvvI/mnKrpgZTmiJDliJcKJ1A3OiDjg53jgqTjg7Pjg4jku5jkuI7liJcKUHJpdmF0ZSBTdWIgYWRkX3BvaW50KG1haW5ibV9jZWxsIEFzIFN0cmluZywgdGFuYm1fY2VsbCBBcyBTdHJpbmcsIGJ1bW9uX2NvbCBBcyBTdHJpbmcsIGtlaV9jb2wgQXMgU3RyaW5nLCBqaXNfY29sIEFzIFN0cmluZywgdGFzX2NvbCBBcyBTdHJpbmcsIHBvaW50X2NvbCBBcyBTdHJpbmcpCiAgICBEaW0gbWF4cm93IEFzIExvbmcKICAgIERpbSB3cm93IEFzIExvbmcKICAgIERpbSBtcG9pbnQgQXMgVmFyaWFudCAgICAgICAn5rqA6aGN44Od44Kk44Oz44OICiAgICBEaW0gbWFpbmJtX3ZhbCBBcyBWYXJpYW50ICAgJ+S4u+aLheW9k+mDqOmWgAogICAgRGltIHBvaW50IEFzIExvbmcgICAgICAgJ+mWi+Wni3BvaW50CiAgICBEaW0gYXAgQXMgRG91YmxlICAgICAgICAncG9pbnQKICAgIERpbSBidW1vbl9jb2xObyBBcyBMb25nICfpg6jploDvvIjmi6DngrnvvInjga7liJfnlarlj7cKICAgIERpbSB0YW5faWQgQXMgU3RyaW5nICAgICfmi4XlvZNJRO+8iOiqsuWIpe+8ieiLpeOBl+OBj+OBr+aLheW9k+iAheS4u+aLheW9k+mDqOmWgOOCs+ODvOODiQogICAgRGltIGlkcm93IEFzIExvbmcgICAgICAgJ+KYhUlE44Gu6KGM55Wq5Y+3CiAgICBEaW0ga2V5IEFzIFZhcmlhbnQKICAgIGJ1bW9uX2NvbE5vID0gUmFuZ2UoYnVtb25fY29sICYgIjEiKS5Db2x1bW4KICAgICfjg53jgqTjg7Pjg4jlj5blvpcKICAgIG1haW5ibV92YWwgPSB3a3MuUmFuZ2UobWFpbmJtX2NlbGwpCiAgICBtcG9pbnQgPSBBcHBsaWNhdGlvbi5ITG9va3VwKG1haW5ibV92YWwsIGprcy5SYW5nZSgiQjE5OkQyMSIpLCAzLCAwKQogICAgSWYgSXNFcnJvcihtcG9pbnQpIFRoZW4KICAgICAgICBNc2dCb3ggKCLimIXmnaHku7bjgrfjg7zjg4jjga7jg53jgqTjg7Pjg4jlj5blvpfjgqjjg6njg7zvvJrkuLvmi4XlvZPpg6jploA8IiAmIG1haW5ibV92YWwgJiAiPiIpCiAgICAgICAgTXNnQm94ICgi566X5Ye644Od44Kk44Oz44OI5YiXPSIgJiBwb2ludF9jb2wpCiAgICAgICAgQXBwbGljYXRpb24uQ2FsY3VsYXRpb24gPSB4bENhbGN1bGF0aW9uQXV0b21hdGljCiAgICAgICAgRW5kCiAgICBFbmQgSWYKICAgIHBvaW50ID0gbXBvaW50CiAgICBtYXhyb3cgPSB3a3MuQ2VsbHMoUm93cy5Db3VudCwgIkEiKS5FbmQoeGxVcCkuUm93ICAgICAgICAgICAgICdB5YiX5pyA57WC6KGMCiAgICB3a3MuUmFuZ2UocG9pbnRfY29sICYgIjU6IiAmIHBvaW50X2NvbCAmIG1heHJvdykuVmFsdWUgPSAwICAgICfjg53jgqTjg7Pjg4jooYzjgpLvvJDjgq/jg6rjgqIKICAgIEZvciB3cm93ID0gNSBUbyBtYXhyb3cKICAgICAgICAn6YOo6ZaA77yI5oug54K577yJ44Gq44GX44Gq44KJ57WC5LqGCiAgICAgICAgSWYgd2tzLkNlbGxzKHdyb3csIGJ1bW9uX2NvbCkgPSAiIiBUaGVuIEV4aXQgRm9yCiAgICAgICAgJ+ipsuW9k+ihjOOBruaLheW9k+iAheS4u+aLheW9k+mDqOmWgOOCs+ODvOODieOCkuWPluW+l+OBmeOCiwogICAgICAgIGtleSA9IHdrcy5DZWxscyh3cm93LCBidW1vbl9jb2xObykgJiAifCIgJiB3a3MuQ2VsbHMod3JvdywgYnVtb25fY29sTm8gKyAxKSAmICJ8IiAmIHdrcy5DZWxscyh3cm93LCBidW1vbl9jb2xObyArIDIpCiAgICAgICAgSWYgZGljVC5leGlzdHMoa2V5KSA9IEZhbHNlIFRoZW4KICAgICAgICAgICAgTXNnQm94ICgi4piFSUTjgrfjg7zjg4jjgavmnKrnmbvpjLI8IiAmIGtleSAmICI+IikKICAgICAgICAgICAgTXNnQm94ICgi6KGM55Wq5Y+3PSIgJiB3cm93ICYgIiDpg6jploDvvIjmi6DngrnvvInliJc9IiAmIGJ1bW9uX2NvbCAmICIg566X5Ye644Od44Kk44Oz44OI5YiXPSIgJiBwb2ludF9jb2wpCiAgICAgICAgICAgIGFwID0gMAogICAgICAgIEVsc2UKICAgICAgICAgICAgdGFuX2lkID0gZGljVChrZXkpCiAgICAgICAgICAgICfoqbLlvZPooYzjga7jg53jgqTjg7Pjg4jjgpLlj5blvpfjgZnjgosKICAgICAgICAgICAgYXAgPSBnZXRfcG9pbnQod3JvdywgdGFuYm1fY2VsbCwgdGFuX2lkLCBrZWlfY29sLCBqaXNfY29sLCB0YXNfY29sLCBwb2ludCkKICAgICAgICBFbmQgSWYKICAgICAgICB3a3MuQ2VsbHMod3JvdywgcG9pbnRfY29sKS5WYWx1ZSA9IGFwCiAgICAgICAgJ+S7mOS4juODneOCpOODs+ODiOOBjOOBguOCi+OBquOCieOAgeODneOCpOODs+ODiOOBi+OCie+8keW8leOBjwogICAgICAgIElmIGFwIDw+IDAgVGhlbgogICAgICAgICAgICBwb2ludCA9IHBvaW50IC0gMQogICAgICAgIEVuZCBJZgogICAgTmV4dApFbmQgU3ViCifjgrfjg7zjg4jlkI3lj5blvpcKUHJpdmF0ZSBGdW5jdGlvbiBnZXRfc2hlZXQoc25hbWUgQXMgU3RyaW5nLCB3cyBBcyBXb3Jrc2hlZXQpCiAgICBPbiBFcnJvciBHb1RvIEVSUjk5CiAgICBTZXQgd3MgPSBXb3Jrc2hlZXRzKHNuYW1lKQogICAgZ2V0X3NoZWV0ID0gVHJ1ZQogICAgRXhpdCBGdW5jdGlvbgpFUlI5OToKICAgIGdldF9zaGVldCA9IEZhbHNlCkVuZCBGdW5jdGlvbgon5ouF5b2TSUTjgrvjg4Pjg4jjgqLjg4Pjg5cKUHJpdmF0ZSBTdWIgc2V0dXBfdGFuaWQoKQogICAgRGltIG1heHJvdyBBcyBMb25nCiAgICBEaW0gd3JvdyBBcyBMb25nCiAgICBEaW0ga2V5IEFzIFZhcmlhbnQKICAgIG1heHJvdyA9IGlkcy5DZWxscyhSb3dzLkNvdW50LCAiQSIpLkVuZCh4bFVwKS5Sb3cgICAgICAgICAgICAgJ0HliJfmnIDntYLooYwKICAgIEZvciB3cm93ID0gMyBUbyBtYXhyb3cKICAgICAgICBrZXkgPSBpZHMuQ2VsbHMod3JvdywgIkIiKS5WYWx1ZSAmICJ8IiAmIGlkcy5DZWxscyh3cm93LCAiQyIpLlZhbHVlICYgInwiICYgaWRzLkNlbGxzKHdyb3csICJEIikuVmFsdWUKICAgICAgICBkaWNUKGtleSkgPSBpZHMuQ2VsbHMod3JvdywgIkciKS5WYWx1ZQogICAgTmV4dApFbmQgU3ViCifku5jkuI7jg53jgqTjg7Pjg4jlj5blvpcKUHJpdmF0ZSBGdW5jdGlvbiBnZXRfcG9pbnQod3JvdyBBcyBMb25nLCB0YW5ibV9jZWxsIEFzIFN0cmluZywgdGFuX2lkIEFzIFN0cmluZywga2VpX2NvbCBBcyBTdHJpbmcsIGppc19jb2wgQXMgU3RyaW5nLCB0YXNfY29sIEFzIFN0cmluZywgcG9pbnQgQXMgTG9uZykKICAgIERpbSBrZWlfdmFsIEFzIFZhcmlhbnQgICfoqIjnlLsKICAgIERpbSBqaXNfdmFsIEFzIFZhcmlhbnQgICflrp/nuL4KICAgIERpbSB0YXNfdmFsIEFzIFZhcmlhbnQgICfpgZTmiJDvvI/mnKrpgZTmiJAKICAgIERpbSByYXRlIEFzIERvdWJsZSAgICAgICfjg53jgqTjg7Pjg4jjg6zjg7zjg4jvvIUKICAgIGdldF9wb2ludCA9IDAKICAgIHJhdGUgPSAwCiAgICBrZWlfdmFsID0gd2tzLkNlbGxzKHdyb3csIGtlaV9jb2wpCiAgICBqaXNfdmFsID0gd2tzLkNlbGxzKHdyb3csIGppc19jb2wpCiAgICB0YXNfdmFsID0gd2tzLkNlbGxzKHdyb3csIHRhc19jb2wpCiAgICBJZiBrZWlfdmFsIDw9IDAgQW5kIGppc192YWwgPD0gMCBUaGVuIEV4aXQgRnVuY3Rpb24KICAgIElmIHdrcy5SYW5nZSh0YW5ibV9jZWxsKS5WYWx1ZSA9IHRhbl9pZCBUaGVuCiAgICAgICAgJ+aLheW9k+iAheS4u+aLheW9k+mDqOmWgOOBqOaLheW9k0lE44GM5LiA6Ie0CiAgICAgICAgSWYgdGFzX3ZhbCA+IDAgVGhlbgogICAgICAgICAgICAn6YGU5oiQ77yP5pyq6YGU5oiQ77ye77yQCiAgICAgICAgICAgIElmIGtlaV92YWwgPj0gMCBBbmQgamlzX3ZhbCA+IDAgVGhlbiByYXRlID0gMTAwCiAgICAgICAgRW5kIElmCiAgICAgICAgSWYgdGFzX3ZhbCA8IDAgVGhlbgogICAgICAgICAgICAn6YGU5oiQ77yP5pyq6YGU5oiQ77yc77yQCiAgICAgICAgICAgIElmIGtlaV92YWwgPiAwIFRoZW4gcmF0ZSA9IDc1CiAgICAgICAgRW5kIElmCiAgICBFbHNlCiAgICAgICAgJ+aLheW9k+iAheS4u+aLheW9k+mDqOmWgOOBqOaLheW9k0lE44GM5LiN5LiA6Ie0CiAgICAgICAgSWYgdGFzX3ZhbCA+IDAgVGhlbgogICAgICAgICAgICAn6YGU5oiQ77yP5pyq6YGU5oiQ77ye77yQCiAgICAgICAgICAgIElmIGtlaV92YWwgPSAwIEFuZCBqaXNfdmFsID4gMCBUaGVuIHJhdGUgPSAxMi41CiAgICAgICAgICAgIElmIGtlaV92YWwgPiAwIEFuZCBqaXNfdmFsID4gMCBUaGVuIHJhdGUgPSAyNQogICAgICAgIEVuZCBJZgogICAgRW5kIElmCiAgICBnZXRfcG9pbnQgPSBwb2ludCAqIHJhdGUgLyAxMDAKRW5kIEZ1bmN0aW9uCg==