Option Explicit
Dim row3 As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim dicST As Object
Dim dicEN As Object
Public Sub 転記()
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As String       '車種
    Set ws1 = Sheets("在庫一覧")
    Set ws2 = Sheets("まとめ")
    Set ws3 = Sheets("転記先")
    Set dicST = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set dicEN = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    maxrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row    'A列の最大行取得
    maxrow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row    'B列の最大行取得
    If maxrow1 < 5 Then Exit Sub
    If maxrow2 < 6 Then Exit Sub
    ws3.Rows("6:" & Rows.Count).ClearContents
    row3 = 6
    '車種を取り込む
    For row1 = 5 To maxrow1
        key = ws1.Cells(row1, "A").Value
        If dicST.exists(key) = False Then
            dicST(key) = row1
            dicEN(key) = row1
        Else
            If dicEN(key) + 1 <> row1 Then
                ws1.Activate
                ws1.Cells(row1, "A").Select
                MsgBox ("車種が連続していません")
                Exit Sub
            End If
            dicEN(key) = row1
        End If
    Next
    For row2 = 6 To maxrow2
        key = ws2.Cells(row2, "B").Value
        If dicST.exists(key) = False Then
            ws2.Activate
            ws2.Cells(row2, "B").Select
            MsgBox ("車種が在庫一覧にありません")
            Exit Sub
        End If
        Call tenki(key, row2)
        dicST.Remove key
        dicEN.Remove key
    Next
    'ソート用キーをクリア
    ws3.Range("K6:L" & Rows.Count).ClearContents
    MsgBox ("完了")
End Sub
 
Private Sub tenki(ByVal key As String, ByVal row2 As Long)
    Dim wrow As Long
    Dim rcnt As Long
    Dim srow1 As Long
    Dim wrow3 As Long
    Dim i As Long
    Dim ratio As Double
    Dim m_weight As Variant    '必要重量
    Dim p_weight As Variant    '部品重量
    rcnt = dicEN(key) - dicST(key) + 1
    srow1 = dicST(key)
    For i = 0 To rcnt - 1
        '車種、型式、必要重量
        ws3.Cells(row3 + i, "B").Resize(1, 3).Value = ws2.Cells(row2, "B").Resize(1, 3).Value
        '製造No、部品重量
        ws3.Cells(row3 + i, "E").Resize(1, 2).Value = ws1.Cells(srow1 + i, "C").Resize(1, 2).Value
        '部品単量
        ws3.Cells(row3 + i, "G").Value = ws2.Cells(row2, "G").Value
        '不良品
        ws3.Cells(row3 + i, "H").Value = ws1.Cells(srow1 + i, "F").Value
    Next
    '判定処理
    For i = 0 To rcnt - 1
        If ws3.Cells(row3 + i, "H").Value = "不良" Then
            ws3.Cells(row3 + i, "A").Value = "他"
            ws3.Cells(row3 + i, "i").Value = "なし"  '結果
            ws3.Cells(row3 + i, "K").Value = 9       'ソート用第１キー
            ws3.Cells(row3 + i, "L").Value = 0       'ソート用第２キー
        Else
            m_weight = ws3.Cells(row3 + i, "D").Value
            p_weight = ws3.Cells(row3 + i, "F").Value
            If IsNumeric(m_weight) = False Then
                ws3.Activate
                ws3.Cells(row3 + i, "D").Select
                MsgBox ("必要重量が不正です")
                End
            End If
            If m_weight = 0 Then
                ws3.Activate
                ws3.Cells(row3 + i, "D").Select
                MsgBox ("必要重量が0です")
                End
            End If
            If IsNumeric(p_weight) = False Then
                ws3.Activate
                ws3.Cells(row3 + i, "F").Select
                MsgBox ("部品重量が不正です")
                End
            End If
            ratio = (p_weight - m_weight) / m_weight
            If Abs(ratio) <= 0.1 Then
                ws3.Cells(row3 + i, "A").Value = "○"    '状態
                ws3.Cells(row3 + i, "K").Value = 1       'ソート用第１キー
            Else
                ws3.Cells(row3 + i, "A").Value = "他"    '状態
                ws3.Cells(row3 + i, "i").Value = "なし"  '結果
                ws3.Cells(row3 + i, "K").Value = 2       'ソート用第１キー
            End If
            ws3.Cells(row3 + i, "L").Value = Abs(ratio)  'ソート用第２キー
        End If
    Next
    'ソート
    ws3.Range("A" & row3 & ":L" & row3 + rcnt - 1).Sort key1:=ws3.Range("K" & row3), key2:=ws3.Range("L" & row3)
    '車種、型式、必要重量の重複部、部品単量をクリア
    For i = 1 To rcnt - 1
        ws3.Cells(row3 + i, "B").Resize(1, 3).Value = ""
        ws3.Cells(row3 + i, "G").Value = ""
    Next
    row3 = row3 + rcnt + 1
End Sub
 

T3B0aW9uIEV4cGxpY2l0CkRpbSByb3czIEFzIExvbmcKRGltIHdzMSBBcyBXb3Jrc2hlZXQKRGltIHdzMiBBcyBXb3Jrc2hlZXQKRGltIHdzMyBBcyBXb3Jrc2hlZXQKRGltIGRpY1NUIEFzIE9iamVjdApEaW0gZGljRU4gQXMgT2JqZWN0ClB1YmxpYyBTdWIg6Lui6KiYKCkKICAgIERpbSBtYXhyb3cxIEFzIExvbmcKICAgIERpbSBtYXhyb3cyIEFzIExvbmcKICAgIERpbSByb3cxIEFzIExvbmcKICAgIERpbSByb3cyIEFzIExvbmcKICAgIERpbSBrZXkgQXMgU3RyaW5nICAgICAgICfou4rnqK4KICAgIFNldCB3czEgPSBTaGVldHMoIuWcqOW6q+S4gOimpyIpCiAgICBTZXQgd3MyID0gU2hlZXRzKCLjgb7jgajjgoEiKQogICAgU2V0IHdzMyA9IFNoZWV0cygi6Lui6KiY5YWIIikKICAgIFNldCBkaWNTVCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAgICAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgU2V0IGRpY0VOID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpICAgICcg6YCj5oOz6YWN5YiX44Gu5a6a576pCiAgICBtYXhyb3cxID0gd3MxLkNlbGxzKFJvd3MuQ291bnQsIDEpLkVuZCh4bFVwKS5Sb3cgICAgJ0HliJfjga7mnIDlpKfooYzlj5blvpcKICAgIG1heHJvdzIgPSB3czIuQ2VsbHMoUm93cy5Db3VudCwgMikuRW5kKHhsVXApLlJvdyAgICAnQuWIl+OBruacgOWkp+ihjOWPluW+lwogICAgSWYgbWF4cm93MSA8IDUgVGhlbiBFeGl0IFN1YgogICAgSWYgbWF4cm93MiA8IDYgVGhlbiBFeGl0IFN1YgogICAgd3MzLlJvd3MoIjY6IiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMKICAgIHJvdzMgPSA2CiAgICAn6LuK56iu44KS5Y+W44KK6L6844KACiAgICBGb3Igcm93MSA9IDUgVG8gbWF4cm93MQogICAgICAgIGtleSA9IHdzMS5DZWxscyhyb3cxLCAiQSIpLlZhbHVlCiAgICAgICAgSWYgZGljU1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIGRpY1NUKGtleSkgPSByb3cxCiAgICAgICAgICAgIGRpY0VOKGtleSkgPSByb3cxCiAgICAgICAgRWxzZQogICAgICAgICAgICBJZiBkaWNFTihrZXkpICsgMSA8PiByb3cxIFRoZW4KICAgICAgICAgICAgICAgIHdzMS5BY3RpdmF0ZQogICAgICAgICAgICAgICAgd3MxLkNlbGxzKHJvdzEsICJBIikuU2VsZWN0CiAgICAgICAgICAgICAgICBNc2dCb3ggKCLou4rnqK7jgYzpgKPntprjgZfjgabjgYTjgb7jgZvjgpMiKQogICAgICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIGRpY0VOKGtleSkgPSByb3cxCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICBGb3Igcm93MiA9IDYgVG8gbWF4cm93MgogICAgICAgIGtleSA9IHdzMi5DZWxscyhyb3cyLCAiQiIpLlZhbHVlCiAgICAgICAgSWYgZGljU1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIHdzMi5BY3RpdmF0ZQogICAgICAgICAgICB3czIuQ2VsbHMocm93MiwgIkIiKS5TZWxlY3QKICAgICAgICAgICAgTXNnQm94ICgi6LuK56iu44GM5Zyo5bqr5LiA6Kan44Gr44GC44KK44G+44Gb44KTIikKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICBDYWxsIHRlbmtpKGtleSwgcm93MikKICAgICAgICBkaWNTVC5SZW1vdmUga2V5CiAgICAgICAgZGljRU4uUmVtb3ZlIGtleQogICAgTmV4dAogICAgJ+OCveODvOODiOeUqOOCreODvOOCkuOCr+ODquOCogogICAgd3MzLlJhbmdlKCJLNjpMIiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKClByaXZhdGUgU3ViIHRlbmtpKEJ5VmFsIGtleSBBcyBTdHJpbmcsIEJ5VmFsIHJvdzIgQXMgTG9uZykKICAgIERpbSB3cm93IEFzIExvbmcKICAgIERpbSByY250IEFzIExvbmcKICAgIERpbSBzcm93MSBBcyBMb25nCiAgICBEaW0gd3JvdzMgQXMgTG9uZwogICAgRGltIGkgQXMgTG9uZwogICAgRGltIHJhdGlvIEFzIERvdWJsZQogICAgRGltIG1fd2VpZ2h0IEFzIFZhcmlhbnQgICAgJ+W/heimgemHjemHjwogICAgRGltIHBfd2VpZ2h0IEFzIFZhcmlhbnQgICAgJ+mDqOWTgemHjemHjwogICAgcmNudCA9IGRpY0VOKGtleSkgLSBkaWNTVChrZXkpICsgMQogICAgc3JvdzEgPSBkaWNTVChrZXkpCiAgICBGb3IgaSA9IDAgVG8gcmNudCAtIDEKICAgICAgICAn6LuK56iu44CB5Z6L5byP44CB5b+F6KaB6YeN6YePCiAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiQiIpLlJlc2l6ZSgxLCAzKS5WYWx1ZSA9IHdzMi5DZWxscyhyb3cyLCAiQiIpLlJlc2l6ZSgxLCAzKS5WYWx1ZQogICAgICAgICfoo73pgKBOb+OAgemDqOWTgemHjemHjwogICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkUiKS5SZXNpemUoMSwgMikuVmFsdWUgPSB3czEuQ2VsbHMoc3JvdzEgKyBpLCAiQyIpLlJlc2l6ZSgxLCAyKS5WYWx1ZQogICAgICAgICfpg6jlk4HljZjph48KICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJHIikuVmFsdWUgPSB3czIuQ2VsbHMocm93MiwgIkciKS5WYWx1ZQogICAgICAgICfkuI3oia/lk4EKICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJIIikuVmFsdWUgPSB3czEuQ2VsbHMoc3JvdzEgKyBpLCAiRiIpLlZhbHVlCiAgICBOZXh0CiAgICAn5Yik5a6a5Yem55CGCiAgICBGb3IgaSA9IDAgVG8gcmNudCAtIDEKICAgICAgICBJZiB3czMuQ2VsbHMocm93MyArIGksICJIIikuVmFsdWUgPSAi5LiN6ImvIiBUaGVuCiAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkEiKS5WYWx1ZSA9ICLku5YiCiAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgImkiKS5WYWx1ZSA9ICLjgarjgZciICAn57WQ5p6cCiAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIksiKS5WYWx1ZSA9IDkgICAgICAgJ+OCveODvOODiOeUqOesrO+8keOCreODvAogICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJMIikuVmFsdWUgPSAwICAgICAgICfjgr3jg7zjg4jnlKjnrKzvvJLjgq3jg7wKICAgICAgICBFbHNlCiAgICAgICAgICAgIG1fd2VpZ2h0ID0gd3MzLkNlbGxzKHJvdzMgKyBpLCAiRCIpLlZhbHVlCiAgICAgICAgICAgIHBfd2VpZ2h0ID0gd3MzLkNlbGxzKHJvdzMgKyBpLCAiRiIpLlZhbHVlCiAgICAgICAgICAgIElmIElzTnVtZXJpYyhtX3dlaWdodCkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgICAgICB3czMuQWN0aXZhdGUKICAgICAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkQiKS5TZWxlY3QKICAgICAgICAgICAgICAgIE1zZ0JveCAoIuW/heimgemHjemHj+OBjOS4jeato+OBp+OBmSIpCiAgICAgICAgICAgICAgICBFbmQKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIElmIG1fd2VpZ2h0ID0gMCBUaGVuCiAgICAgICAgICAgICAgICB3czMuQWN0aXZhdGUKICAgICAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkQiKS5TZWxlY3QKICAgICAgICAgICAgICAgIE1zZ0JveCAoIuW/heimgemHjemHj+OBjDDjgafjgZkiKQogICAgICAgICAgICAgICAgRW5kCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICBJZiBJc051bWVyaWMocF93ZWlnaHQpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAgICAgd3MzLkFjdGl2YXRlCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJGIikuU2VsZWN0CiAgICAgICAgICAgICAgICBNc2dCb3ggKCLpg6jlk4Hph43ph4/jgYzkuI3mraPjgafjgZkiKQogICAgICAgICAgICAgICAgRW5kCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICByYXRpbyA9IChwX3dlaWdodCAtIG1fd2VpZ2h0KSAvIG1fd2VpZ2h0CiAgICAgICAgICAgIElmIEFicyhyYXRpbykgPD0gMC4xIFRoZW4KICAgICAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkEiKS5WYWx1ZSA9ICLil4siICAgICfnirbmhYsKICAgICAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIksiKS5WYWx1ZSA9IDEgICAgICAgJ+OCveODvOODiOeUqOesrO+8keOCreODvAogICAgICAgICAgICBFbHNlCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJBIikuVmFsdWUgPSAi5LuWIiAgICAn54q25oWLCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJpIikuVmFsdWUgPSAi44Gq44GXIiAgJ+e1kOaenAogICAgICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiSyIpLlZhbHVlID0gMiAgICAgICAn44K944O844OI55So56ys77yR44Kt44O8CiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJMIikuVmFsdWUgPSBBYnMocmF0aW8pICAn44K944O844OI55So56ys77yS44Kt44O8CiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICAn44K944O844OICiAgICB3czMuUmFuZ2UoIkEiICYgcm93MyAmICI6TCIgJiByb3czICsgcmNudCAtIDEpLlNvcnQga2V5MTo9d3MzLlJhbmdlKCJLIiAmIHJvdzMpLCBrZXkyOj13czMuUmFuZ2UoIkwiICYgcm93MykKICAgICfou4rnqK7jgIHlnovlvI/jgIHlv4XopoHph43ph4/jga7ph43opIfpg6jjgIHpg6jlk4HljZjph4/jgpLjgq/jg6rjgqIKICAgIEZvciBpID0gMSBUbyByY250IC0gMQogICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkIiKS5SZXNpemUoMSwgMykuVmFsdWUgPSAiIgogICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkciKS5WYWx1ZSA9ICIiCiAgICBOZXh0CiAgICByb3czID0gcm93MyArIHJjbnQgKyAxCkVuZCBTdWIK