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 転記2()
    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
    '転記先　6行以降をクリア
    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
    'まとめシートを1行毎に処理する
    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
 
'転記処理 key:車種 row2:まとめの行番号
Private Sub tenki(ByVal key As String, ByVal row2 As Long)
    Dim rcnt As Long            '該当者車種の行数（在庫一覧）
    Dim srow1 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
 
 
 
 
 

T3B0aW9uIEV4cGxpY2l0CkRpbSByb3czIEFzIExvbmcgICAgICAgICfou6LoqJjlhYjooYznlarlj7cKRGltIHdzMSBBcyBXb3Jrc2hlZXQgICAgJ+WcqOW6q+S4gOimp+OCt+ODvOODiApEaW0gd3MyIEFzIFdvcmtzaGVldCAgICAn44G+44Go44KB44K344O844OICkRpbSB3czMgQXMgV29ya3NoZWV0ICAgICfou6LoqJjlhYjjgrfjg7zjg4gKRGltIGRpY1NUIEFzIE9iamVjdCAgICAgJ+mAo+aDs+mFjeWIlyDjgq3jg7zvvJrou4rnqK4g5YCk77ya5pyA5Yid44Gr5Ye654++44GZ44KL6KGM55Wq5Y+377yI5Zyo5bqr5LiA6Kan77yJCkRpbSBkaWNFTiBBcyBPYmplY3QgICAgICfpgKPmg7PphY3liJcg44Kt44O877ya6LuK56iuIOWApO+8muacgOW+jOOBq+WHuuePvuOBmeOCi+ihjOeVquWPt++8iOWcqOW6q+S4gOimp++8iQpQdWJsaWMgU3ViIOi7ouiomDIoKQogICAgRGltIG1heHJvdzEgQXMgTG9uZyAn5pyA5aSn6KGM5pWwICAg5Zyo5bqr5LiA6KanCiAgICBEaW0gbWF4cm93MiBBcyBMb25nICfmnIDlpKfooYzmlbAgICDjgb7jgajjgoEKICAgIERpbSByb3cxIEFzIExvbmcgICAgJ+ihjOeVquWPtyAgICAg5Zyo5bqr5LiA6KanCiAgICBEaW0gcm93MiBBcyBMb25nICAgICfooYznlarlj7cgICAgIOWcqOW6q+S4gOimpwogICAgRGltIGtleSBBcyBTdHJpbmcgICAgICAgJ+i7iueorgogICAgU2V0IHdzMSA9IFNoZWV0cygi5Zyo5bqr5LiA6KanIikKICAgIFNldCB3czIgPSBTaGVldHMoIuOBvuOBqOOCgSIpCiAgICBTZXQgd3MzID0gU2hlZXRzKCLou6LoqJjlhYgiKQogICAgU2V0IGRpY1NUID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpICAgICcg6YCj5oOz6YWN5YiX44Gu5a6a576pCiAgICBTZXQgZGljRU4gPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgICAgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgIG1heHJvdzEgPSB3czEuQ2VsbHMoUm93cy5Db3VudCwgMSkuRW5kKHhsVXApLlJvdyAgICAnQeWIl+OBruacgOWkp+ihjOWPluW+lwogICAgbWF4cm93MiA9IHdzMi5DZWxscyhSb3dzLkNvdW50LCAyKS5FbmQoeGxVcCkuUm93ICAgICdC5YiX44Gu5pyA5aSn6KGM5Y+W5b6XCiAgICAn5pyA5aSn6KGM5pWw44GM6KaB5Lu244KS5rqA44Gf44GX44Gm44Gq44GE44Gq44KJ5Yem55CG44GX44Gq44GECiAgICBJZiBtYXhyb3cxIDwgNSBUaGVuIEV4aXQgU3ViCiAgICBJZiBtYXhyb3cyIDwgNiBUaGVuIEV4aXQgU3ViCiAgICAn6Lui6KiY5YWI44CANuihjOS7pemZjeOCkuOCr+ODquOCogogICAgd3MzLlJvd3MoIjY6IiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMKICAgIHJvdzMgPSA2CiAgICAn6LuK56iu44KS5Y+W44KK6L6844KACiAgICBGb3Igcm93MSA9IDUgVG8gbWF4cm93MQogICAgICAgIGtleSA9IHdzMS5DZWxscyhyb3cxLCAiQSIpLlZhbHVlCiAgICAgICAgSWYgZGljU1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIGRpY1NUKGtleSkgPSByb3cxCiAgICAgICAgICAgIGRpY0VOKGtleSkgPSByb3cxCiAgICAgICAgRWxzZQogICAgICAgICAgICBJZiBkaWNFTihrZXkpICsgMSA8PiByb3cxIFRoZW4KICAgICAgICAgICAgICAgIHdzMS5BY3RpdmF0ZQogICAgICAgICAgICAgICAgd3MxLkNlbGxzKHJvdzEsICJBIikuU2VsZWN0CiAgICAgICAgICAgICAgICBNc2dCb3ggKCLou4rnqK7jgYzpgKPntprjgZfjgabjgYTjgb7jgZvjgpMiKQogICAgICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIGRpY0VOKGtleSkgPSByb3cxCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICAn44G+44Go44KB44K344O844OI44KSMeihjOavjuOBq+WHpueQhuOBmeOCiwogICAgRm9yIHJvdzIgPSA2IFRvIG1heHJvdzIKICAgICAgICBrZXkgPSB3czIuQ2VsbHMocm93MiwgIkIiKS5WYWx1ZQogICAgICAgIElmIGRpY1NULmV4aXN0cyhrZXkpID0gRmFsc2UgVGhlbgogICAgICAgICAgICB3czIuQWN0aXZhdGUKICAgICAgICAgICAgd3MyLkNlbGxzKHJvdzIsICJCIikuU2VsZWN0CiAgICAgICAgICAgIE1zZ0JveCAoIui7iueoruOBjOWcqOW6q+S4gOimp+OBq+OBguOCiuOBvuOBm+OCkyIpCiAgICAgICAgICAgIEV4aXQgU3ViCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+i7ouiomOWHpueQhu+8iOi7iueoruOAgeOBvuOBqOOCgeOBruihjOeVquWPt++8iQogICAgICAgIENhbGwgdGVua2koa2V5LCByb3cyKQogICAgICAgICfoqbLlvZPou4rnqK7jga7pgKPmg7PphY3liJfjgpLliYrpmaQKICAgICAgICBkaWNTVC5SZW1vdmUga2V5CiAgICAgICAgZGljRU4uUmVtb3ZlIGtleQogICAgTmV4dAogICAgJ+OCveODvOODiOeUqOOCreODvOOCkuOCr+ODquOCogogICAgd3MzLlJhbmdlKCJLNjpMIiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKCifou6LoqJjlh6bnkIYga2V5Oui7iueoriByb3cyOuOBvuOBqOOCgeOBruihjOeVquWPtwpQcml2YXRlIFN1YiB0ZW5raShCeVZhbCBrZXkgQXMgU3RyaW5nLCBCeVZhbCByb3cyIEFzIExvbmcpCiAgICBEaW0gcmNudCBBcyBMb25nICAgICAgICAgICAgJ+ipsuW9k+iAhei7iueoruOBruihjOaVsO+8iOWcqOW6q+S4gOimp++8iQogICAgRGltIHNyb3cxIEFzIExvbmcgICAgICAgICAgICfoqbLlvZPou4rnqK7jga7plovlp4vooYzvvIjlnKjluqvkuIDopqfvvIkKICAgIERpbSBpIEFzIExvbmcKICAgIERpbSByYXRpbyBBcyBEb3VibGUgICAgICAgICAn5q+U546HCiAgICBEaW0gbV93ZWlnaHQgQXMgVmFyaWFudCAgICAgJ+W/heimgemHjemHjwogICAgRGltIHBfd2VpZ2h0IEFzIFZhcmlhbnQgICAgICfpg6jlk4Hph43ph48KICAgIHJjbnQgPSBkaWNFTihrZXkpIC0gZGljU1Qoa2V5KSArIDEKICAgIHNyb3cxID0gZGljU1Qoa2V5KQogICAgJ+WcqOW6q+S4gOimp+WPiuOBs+OBvuOBqOOCgeOBi+OCiei7ouiomOWFiOOBuOi7oumAge+8iOihjOaVsOWIhue5sOOCiui/lOOBme+8iQogICAgRm9yIGkgPSAwIFRvIHJjbnQgLSAxCiAgICAgICAgJ+i7iueoruOAgeWei+W8j+OAgeW/heimgemHjemHjwogICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIkIiKS5SZXNpemUoMSwgMykuVmFsdWUgPSB3czIuQ2VsbHMocm93MiwgIkIiKS5SZXNpemUoMSwgMykuVmFsdWUKICAgICAgICAn6KO96YCgTm/jgIHpg6jlk4Hph43ph48KICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJFIikuUmVzaXplKDEsIDIpLlZhbHVlID0gd3MxLkNlbGxzKHNyb3cxICsgaSwgIkMiKS5SZXNpemUoMSwgMikuVmFsdWUKICAgICAgICAn6YOo5ZOB5Y2Y6YePCiAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiRyIpLlZhbHVlID0gd3MyLkNlbGxzKHJvdzIsICJHIikuVmFsdWUKICAgICAgICAn5LiN6Imv5ZOBCiAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiSCIpLlZhbHVlID0gd3MxLkNlbGxzKHNyb3cxICsgaSwgIkYiKS5WYWx1ZQogICAgTmV4dAogICAgJ+WIpOWumuWHpueQhu+8iOihjOaVsOWIhue5sOOCiui/lOOBme+8iQogICAgRm9yIGkgPSAwIFRvIHJjbnQgLSAxCiAgICAgICAgSWYgd3MzLkNlbGxzKHJvdzMgKyBpLCAiSCIpLlZhbHVlID0gIuS4jeiJryIgVGhlbgogICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJBIikuVmFsdWUgPSAi5LuWIgogICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJpIikuVmFsdWUgPSAi44Gq44GXIiAgJ+e1kOaenAogICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJLIikuVmFsdWUgPSA5ICAgICAgICfjgr3jg7zjg4jnlKjnrKzvvJHjgq3jg7wKICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiTCIpLlZhbHVlID0gMCAgICAgICAn44K944O844OI55So56ys77yS44Kt44O8CiAgICAgICAgRWxzZQogICAgICAgICAgICBtX3dlaWdodCA9IHdzMy5DZWxscyhyb3czICsgaSwgIkQiKS5WYWx1ZQogICAgICAgICAgICBwX3dlaWdodCA9IHdzMy5DZWxscyhyb3czICsgaSwgIkYiKS5WYWx1ZQogICAgICAgICAgICBJZiBJc051bWVyaWMobV93ZWlnaHQpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAgICAgd3MzLkFjdGl2YXRlCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJEIikuU2VsZWN0CiAgICAgICAgICAgICAgICBNc2dCb3ggKCLlv4XopoHph43ph4/jgYzkuI3mraPjgafjgZkiKQogICAgICAgICAgICAgICAgRW5kCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICBJZiBtX3dlaWdodCA9IDAgVGhlbgogICAgICAgICAgICAgICAgd3MzLkFjdGl2YXRlCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJEIikuU2VsZWN0CiAgICAgICAgICAgICAgICBNc2dCb3ggKCLlv4XopoHph43ph4/jgYww44Gn44GZIikKICAgICAgICAgICAgICAgIEVuZAogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgSWYgSXNOdW1lcmljKHBfd2VpZ2h0KSA9IEZhbHNlIFRoZW4KICAgICAgICAgICAgICAgIHdzMy5BY3RpdmF0ZQogICAgICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiRiIpLlNlbGVjdAogICAgICAgICAgICAgICAgTXNnQm94ICgi6YOo5ZOB6YeN6YeP44GM5LiN5q2j44Gn44GZIikKICAgICAgICAgICAgICAgIEVuZAogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgcmF0aW8gPSAocF93ZWlnaHQgLSBtX3dlaWdodCkgLyBtX3dlaWdodAogICAgICAgICAgICBJZiBBYnMocmF0aW8pIDw9IDAuMSBUaGVuCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJBIikuVmFsdWUgPSAi4peLIiAgICAn54q25oWLCiAgICAgICAgICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJLIikuVmFsdWUgPSAxICAgICAgICfjgr3jg7zjg4jnlKjnrKzvvJHjgq3jg7wKICAgICAgICAgICAgRWxzZQogICAgICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiQSIpLlZhbHVlID0gIuS7liIgICAgJ+eKtuaFiwogICAgICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiaSIpLlZhbHVlID0gIuOBquOBlyIgICfntZDmnpwKICAgICAgICAgICAgICAgIHdzMy5DZWxscyhyb3czICsgaSwgIksiKS5WYWx1ZSA9IDIgICAgICAgJ+OCveODvOODiOeUqOesrO+8keOCreODvAogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgd3MzLkNlbGxzKHJvdzMgKyBpLCAiTCIpLlZhbHVlID0gQWJzKHJhdGlvKSAgJ+OCveODvOODiOeUqOesrO+8kuOCreODvAogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ+OCveODvOODiAogICAgd3MzLlJhbmdlKCJBIiAmIHJvdzMgJiAiOkwiICYgcm93MyArIHJjbnQgLSAxKS5Tb3J0IGtleTE6PXdzMy5SYW5nZSgiSyIgJiByb3czKSwga2V5Mjo9d3MzLlJhbmdlKCJMIiAmIHJvdzMpCiAgICAn6LuK56iu44CB5Z6L5byP44CB5b+F6KaB6YeN6YeP44Gu6YeN6KSH6YOo44CB6YOo5ZOB5Y2Y6YeP44KS44Kv44Oq44KiCiAgICBGb3IgaSA9IDEgVG8gcmNudCAtIDEKICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJCIikuUmVzaXplKDEsIDMpLlZhbHVlID0gIiIKICAgICAgICB3czMuQ2VsbHMocm93MyArIGksICJHIikuVmFsdWUgPSAiIgogICAgTmV4dAogICAgcm93MyA9IHJvdzMgKyByY250ICsgMQpFbmQgU3ViCgoKCgo=