Option Explicit
 
Const RESTCOL As String = "E"   'Aシート作業列
Dim ws1 As Worksheet    'Aシート
Dim ws2 As Worksheet    'Bシート
Dim dicST As Object     '連想配列 キー：車種 値：最初に出現する行番号（Aシート）
Dim dicEN As Object     '連想配列 キー：車種 値：最後に出現する行番号（Aシート）
Dim Arr As Variant      'Bシートイメージ保存
Dim row2 As Long        'Bシート　行番号
Public Sub 転記()
    Dim maxrow1 As Long '最大行数   Aシート
    Dim maxrow2 As Long '最大行数   Bシート
    Dim row1 As Long    '行番号     Aシート
    Dim ix As Long      'Arr 添え字
    Dim key As String       '車種
    Set ws1 = Sheets("A")
    Set ws2 = Sheets("B")
    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, 4).End(xlUp).Row    'D列の最大行取得
    '最大行数が要件を満たしてないなら処理しない
    If maxrow1 < 5 Then Exit Sub
    If maxrow2 < 5 Then Exit Sub
    'Bシートを配列へ転送
    Arr = ws2.Range("A5:Z" & maxrow2).Value
    'Bシート　5行以降をクリア
    ws2.Rows("5:" & Rows.Count).ClearContents
    row2 = 5
    '車種を取り込む
    For row1 = 5 To maxrow1
        key = ws1.Cells(row1, "A").Value
        ws1.Cells(row1, RESTCOL).Value = ws1.Cells(row1, "D").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
    'Arrを1列毎に処理する。
    For ix = 1 To UBound(Arr, 1)
        '転記処理（Bシートの行番号）
        Call tenki(ix)
    Next
    ws1.Range(RESTCOL & "5:" & RESTCOL & maxrow1).ClearContents     '作業列クリア
    MsgBox ("完了")
End Sub
 
'転記処理 ix:Arrの添え字
Private Sub tenki(ByVal ix As Long)
    Dim rcnt As Long            '該当者車種の行数（Aシート）
    Dim srow1 As Long           '該当車種の開始行（Aシート）
    Dim key As String       '車種
    Dim rest As Variant     '受注残
    Dim row1 As Long        '行番号　Aシート
    Dim temp As Variant
    'Bシートの１行分（A～Z）をArrから転送
    temp = WorksheetFunction.Index(Arr, ix)
    ws2.Cells(row2, 1).Resize(1, 26).Value = temp
    rest = Arr(ix, 8)   '受注残
    key = Arr(ix, 4)    '車種
    'Aシートに未登録なら終了
    If dicST.exists(key) = False Then
        GoTo FIN99
    End If
    '該当車種の行を繰り返す
    For row1 = dicST(key) To dicEN(key)
        '在庫がない製造番号はスキップする
        If ws1.Cells(row1, RESTCOL).Value = 0 Then GoTo NEXT99
        '受注残が0なら終了
        If rest = 0 Then Exit For
        ws2.Cells(row2, "J").Value = ws1.Cells(row1, "C").Value '製造NO
        If ws1.Cells(row1, RESTCOL).Value >= rest Then
            ws2.Cells(row2, "K").Value = rest                       '在庫
            ws1.Cells(row1, RESTCOL).Value = ws1.Cells(row1, RESTCOL).Value - rest  '在庫残
            rest = 0                                                '受注残
        Else
            ws2.Cells(row2, "K").Value = ws1.Cells(row1, RESTCOL).Value '在庫
            rest = rest - ws1.Cells(row1, RESTCOL).Value            '受注残
            ws1.Cells(row1, RESTCOL).Value = 0                      '在庫残
        End If
        row2 = row2 + 1
NEXT99:
    Next
FIN99:
    row2 = row2 + 1
End Sub
 
 

T3B0aW9uIEV4cGxpY2l0CgpDb25zdCBSRVNUQ09MIEFzIFN0cmluZyA9ICJFIiAgICdB44K344O844OI5L2c5qWt5YiXCkRpbSB3czEgQXMgV29ya3NoZWV0ICAgICdB44K344O844OICkRpbSB3czIgQXMgV29ya3NoZWV0ICAgICdC44K344O844OICkRpbSBkaWNTVCBBcyBPYmplY3QgICAgICfpgKPmg7PphY3liJcg44Kt44O877ya6LuK56iuIOWApO+8muacgOWIneOBq+WHuuePvuOBmeOCi+ihjOeVquWPt++8iEHjgrfjg7zjg4jvvIkKRGltIGRpY0VOIEFzIE9iamVjdCAgICAgJ+mAo+aDs+mFjeWIlyDjgq3jg7zvvJrou4rnqK4g5YCk77ya5pyA5b6M44Gr5Ye654++44GZ44KL6KGM55Wq5Y+377yIQeOCt+ODvOODiO+8iQpEaW0gQXJyIEFzIFZhcmlhbnQgICAgICAnQuOCt+ODvOODiOOCpOODoeODvOOCuOS/neWtmApEaW0gcm93MiBBcyBMb25nICAgICAgICAnQuOCt+ODvOODiOOAgOihjOeVquWPtwpQdWJsaWMgU3ViIOi7ouiomCgpCiAgICBEaW0gbWF4cm93MSBBcyBMb25nICfmnIDlpKfooYzmlbAgICBB44K344O844OICiAgICBEaW0gbWF4cm93MiBBcyBMb25nICfmnIDlpKfooYzmlbAgICBC44K344O844OICiAgICBEaW0gcm93MSBBcyBMb25nICAgICfooYznlarlj7cgICAgIEHjgrfjg7zjg4gKICAgIERpbSBpeCBBcyBMb25nICAgICAgJ0FyciDmt7vjgYjlrZcKICAgIERpbSBrZXkgQXMgU3RyaW5nICAgICAgICfou4rnqK4KICAgIFNldCB3czEgPSBTaGVldHMoIkEiKQogICAgU2V0IHdzMiA9IFNoZWV0cygiQiIpCiAgICBTZXQgZGljU1QgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgICAgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgIFNldCBkaWNFTiA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAgICAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgbWF4cm93MSA9IHdzMS5DZWxscyhSb3dzLkNvdW50LCAxKS5FbmQoeGxVcCkuUm93ICAgICdB5YiX44Gu5pyA5aSn6KGM5Y+W5b6XCiAgICBtYXhyb3cyID0gd3MyLkNlbGxzKFJvd3MuQ291bnQsIDQpLkVuZCh4bFVwKS5Sb3cgICAgJ0TliJfjga7mnIDlpKfooYzlj5blvpcKICAgICfmnIDlpKfooYzmlbDjgYzopoHku7bjgpLmuoDjgZ/jgZfjgabjgarjgYTjgarjgonlh6bnkIbjgZfjgarjgYQKICAgIElmIG1heHJvdzEgPCA1IFRoZW4gRXhpdCBTdWIKICAgIElmIG1heHJvdzIgPCA1IFRoZW4gRXhpdCBTdWIKICAgICdC44K344O844OI44KS6YWN5YiX44G46Lui6YCBCiAgICBBcnIgPSB3czIuUmFuZ2UoIkE1OloiICYgbWF4cm93MikuVmFsdWUKICAgICdC44K344O844OI44CANeihjOS7pemZjeOCkuOCr+ODquOCogogICAgd3MyLlJvd3MoIjU6IiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMKICAgIHJvdzIgPSA1CiAgICAn6LuK56iu44KS5Y+W44KK6L6844KACiAgICBGb3Igcm93MSA9IDUgVG8gbWF4cm93MQogICAgICAgIGtleSA9IHdzMS5DZWxscyhyb3cxLCAiQSIpLlZhbHVlCiAgICAgICAgd3MxLkNlbGxzKHJvdzEsIFJFU1RDT0wpLlZhbHVlID0gd3MxLkNlbGxzKHJvdzEsICJEIikuVmFsdWUgJ+S9nOalreeUqOWcqOW6qwogICAgICAgIElmIGRpY1NULmV4aXN0cyhrZXkpID0gRmFsc2UgVGhlbgogICAgICAgICAgICBkaWNTVChrZXkpID0gcm93MQogICAgICAgICAgICBkaWNFTihrZXkpID0gcm93MQogICAgICAgIEVsc2UKICAgICAgICAgICAgSWYgZGljRU4oa2V5KSArIDEgPD4gcm93MSBUaGVuCiAgICAgICAgICAgICAgICB3czEuQWN0aXZhdGUKICAgICAgICAgICAgICAgIHdzMS5DZWxscyhyb3cxLCAiQSIpLlNlbGVjdAogICAgICAgICAgICAgICAgTXNnQm94ICgi6LuK56iu44GM6YCj57aa44GX44Gm44GE44G+44Gb44KTIikKICAgICAgICAgICAgICAgIEV4aXQgU3ViCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICBkaWNFTihrZXkpID0gcm93MQogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ0FycuOCkjHliJfmr47jgavlh6bnkIbjgZnjgovjgIIKICAgIEZvciBpeCA9IDEgVG8gVUJvdW5kKEFyciwgMSkKICAgICAgICAn6Lui6KiY5Yem55CG77yIQuOCt+ODvOODiOOBruihjOeVquWPt++8iQogICAgICAgIENhbGwgdGVua2koaXgpCiAgICBOZXh0CiAgICB3czEuUmFuZ2UoUkVTVENPTCAmICI1OiIgJiBSRVNUQ09MICYgbWF4cm93MSkuQ2xlYXJDb250ZW50cyAgICAgJ+S9nOalreWIl+OCr+ODquOCogogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1YgoKJ+i7ouiomOWHpueQhiBpeDpBcnLjga7mt7vjgYjlrZcKUHJpdmF0ZSBTdWIgdGVua2koQnlWYWwgaXggQXMgTG9uZykKICAgIERpbSByY250IEFzIExvbmcgICAgICAgICAgICAn6Kmy5b2T6ICF6LuK56iu44Gu6KGM5pWw77yIQeOCt+ODvOODiO+8iQogICAgRGltIHNyb3cxIEFzIExvbmcgICAgICAgICAgICfoqbLlvZPou4rnqK7jga7plovlp4vooYzvvIhB44K344O844OI77yJCiAgICBEaW0ga2V5IEFzIFN0cmluZyAgICAgICAn6LuK56iuCiAgICBEaW0gcmVzdCBBcyBWYXJpYW50ICAgICAn5Y+X5rOo5q6LCiAgICBEaW0gcm93MSBBcyBMb25nICAgICAgICAn6KGM55Wq5Y+344CAQeOCt+ODvOODiAogICAgRGltIHRlbXAgQXMgVmFyaWFudAogICAgJ0Ljgrfjg7zjg4jjga7vvJHooYzliIbvvIhB772eWu+8ieOCkkFycuOBi+OCiei7oumAgQogICAgdGVtcCA9IFdvcmtzaGVldEZ1bmN0aW9uLkluZGV4KEFyciwgaXgpCiAgICB3czIuQ2VsbHMocm93MiwgMSkuUmVzaXplKDEsIDI2KS5WYWx1ZSA9IHRlbXAKICAgIHJlc3QgPSBBcnIoaXgsIDgpICAgJ+WPl+azqOauiwogICAga2V5ID0gQXJyKGl4LCA0KSAgICAn6LuK56iuCiAgICAnQeOCt+ODvOODiOOBq+acqueZu+mMsuOBquOCiee1guS6hgogICAgSWYgZGljU1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgR29UbyBGSU45OQogICAgRW5kIElmCiAgICAn6Kmy5b2T6LuK56iu44Gu6KGM44KS57mw44KK6L+U44GZCiAgICBGb3Igcm93MSA9IGRpY1NUKGtleSkgVG8gZGljRU4oa2V5KQogICAgICAgICflnKjluqvjgYzjgarjgYToo73pgKDnlarlj7fjga/jgrnjgq3jg4Pjg5fjgZnjgosKICAgICAgICBJZiB3czEuQ2VsbHMocm93MSwgUkVTVENPTCkuVmFsdWUgPSAwIFRoZW4gR29UbyBORVhUOTkKICAgICAgICAn5Y+X5rOo5q6L44GMMOOBquOCiee1guS6hgogICAgICAgIElmIHJlc3QgPSAwIFRoZW4gRXhpdCBGb3IKICAgICAgICB3czIuQ2VsbHMocm93MiwgIkoiKS5WYWx1ZSA9IHdzMS5DZWxscyhyb3cxLCAiQyIpLlZhbHVlICfoo73pgKBOTwogICAgICAgIElmIHdzMS5DZWxscyhyb3cxLCBSRVNUQ09MKS5WYWx1ZSA+PSByZXN0IFRoZW4KICAgICAgICAgICAgd3MyLkNlbGxzKHJvdzIsICJLIikuVmFsdWUgPSByZXN0ICAgICAgICAgICAgICAgICAgICAgICAn5Zyo5bqrCiAgICAgICAgICAgIHdzMS5DZWxscyhyb3cxLCBSRVNUQ09MKS5WYWx1ZSA9IHdzMS5DZWxscyhyb3cxLCBSRVNUQ09MKS5WYWx1ZSAtIHJlc3QgICflnKjluqvmrosKICAgICAgICAgICAgcmVzdCA9IDAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAn5Y+X5rOo5q6LCiAgICAgICAgRWxzZQogICAgICAgICAgICB3czIuQ2VsbHMocm93MiwgIksiKS5WYWx1ZSA9IHdzMS5DZWxscyhyb3cxLCBSRVNUQ09MKS5WYWx1ZSAn5Zyo5bqrCiAgICAgICAgICAgIHJlc3QgPSByZXN0IC0gd3MxLkNlbGxzKHJvdzEsIFJFU1RDT0wpLlZhbHVlICAgICAgICAgICAgJ+WPl+azqOauiwogICAgICAgICAgICB3czEuQ2VsbHMocm93MSwgUkVTVENPTCkuVmFsdWUgPSAwICAgICAgICAgICAgICAgICAgICAgICflnKjluqvmrosKICAgICAgICBFbmQgSWYKICAgICAgICByb3cyID0gcm93MiArIDEKTkVYVDk5OgogICAgTmV4dApGSU45OToKICAgIHJvdzIgPSByb3cyICsgMQpFbmQgU3ViCgo=