VBAで、シート間の転記するコードをFOR～NEXTで教えてください。

Question

シート間の転記VBAのコードを記載中ですが、このコードではエラーも出ず、全く転記できません。下記の内容でどのようにコードを修正すれば、転記できますでしょうか？ご教授の方お願いします。
【やりたい事】
・A.xlsmにAシート、Bシートがあります。
下記①～⑧の内容で、AシートからBシートに転記します。
①Aシートの1列目と、Bシート4列目が同じ場合
②かつAシートの7列目、および8列目に何も記載がない場合
③Bシート6列目の数量に合う個数まで
④下記を転記
・Aシートの3列目のデータを、Bシートの10列目へ転記
・Aシートの4列目のデータを、Bシートの11列目へ転記
⑤Aシートの1列目と、Bシート4列目が同じ場合
⑥かつAシートの7列目、および8列目に何も記載がない場合
⑦下記を転記
Aシートの4列目各車種名毎に、それぞれ最大4つのデータを、
④で転記した続きの製造NOを、予備としてAシートから下記を転記
・Aシートの3列目のデータを、Bシートの10列目へ転記
・Aシートの4列目のデータを、Bシートの11列目へ転記
⑧Aシートの1列目と、Bシート4列目が同じ場合
⑨かつAシートの7列目、および8列目に何も記載がない場合
⑩かつBシートの4列目に、同じ車種名があり、3列目に行先が違う物がある場合
⑦で転記した続きの製造NOを、予備としてAシートから下記を転記
・Aシートの3列目のデータを、Bシートの10列目へ転記
・Aシートの4列目のデータを、Bシートの11列目へ転記
⑪AシートのG列またはH列に"○"がある場合⑩
⑩で転記した続きの製造NOを、×としてAシートから下記を転記
・Aシートの3列目のデータを、Bシートの10列目へ転記
・Aシートの4列目のデータを、Bシートの11列目へ転記

【VBAコードの書きかけ途中の物】
Sub TENNKI()
Dim lastRowA As Long
Dim lastRowB As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim 車種名 As String
Dim orderNo As String
Dim quantity As Long
Dim maxCount As Long
Dim rowCount As Long
Dim count As Long
lastRowA = Sheets("A").Cells(Rows.count, 1).End(xlUp).Row
lastRowB = Sheets("B").Cells(Rows.count, 4).End(xlUp).Row
For i = 5 To lastRowA
車種名 = Sheets("A").Cells(i, 1).Value
For j = 1 To 4
rowCount = 0
count = 0
For k = 5 To lastRowB
If Sheets("B").Cells(k, 4).Value = 車種名 Then
rowCount = rowCount + 1
If Sheets("B").Cells(k, 8).Value <> "" Then
quantity = Sheets("B").Cells(k, 8).Value
End If
End If
Next
If count >= quantity Or rowCount = 0 Then
Exit For
End If
If Sheets("A").Cells(i, 1).Value = Sheets("B").Cells(k, 4).Value _
And Sheets("A").Cells(i, 7).Value = "" _
And Sheets("A").Cells(i, 8).Value = "" Then
Sheets("B").Cells(k, 10).Value = Sheets("A").Cells(i, 3).Value
Sheets("B").Cells(k, 11).Value = Sheets("A").Cells(i, 4).Value
count = count + 1
End If
Next
End Sub

すみませんが、よろしくお願いいたします。

Qchan1962 · Accepted Answer

こんにちは
＞1列目のチェックの順番を○→予備→×の順番でデータを転記させることはできますでしょうか？
要件が明確ならば出来ると思います。（要件を提示されましても今回は辞退します）
＞VBAを実行したときに初期化して転記するのでしょうか？
データがある範囲に出力するので出力されない可能性のあるセルの値をまとめてクリアしています
・VBAを実行したときにデータ取得、加工、初期化して転記（出力）する

＞ハイエースのみの場合、エラーがかかりました。
不明な要件、実行環境は把握していませんがエラーについて対策していません
想像できるエラーの理由
データをVariant配列で取得している為
bShtArr4 = .Range("D5:D5")は配列になりません
従ってUBoundはエラーになります　
また対象5行目セルが空白の場合処理が不要なのでExit Subするべきですね

Aシートについては加工しないのと飛び列を踏まえ直接セルやRange変数を使う事が出来ますがBシートは初期化する必要がありますので配列にしています
（値を残しても書き替えられてしまいますので値をどこかに保持しないと正しく処理できない）

＃８の簡単なやっつけ対策コードです
（Aシート部分を含む追加書き替え部分です）
ご質問の参考コードです。要件に合わない部分やエラー対策などを自身で行ってください

該当部分を含む部分
With Sheets("A")
    If .Range("A5") = "" Then Exit Sub
    lastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    aShtArr1 = .Range("A5:A" & lastRowA)
    aShtArr3 = .Range("C5:C" & lastRowA)
    aShtArr4 = .Range("D5:D" & lastRowA)
    aShtArr7 = .Range("G5:G" & lastRowA)
    aShtArr8 = .Range("H5:H" & lastRowA)
End With
Dim bShtArr3, bShtArr4, bShtArr6, bShtArr8
Dim lastRowB As Long
With Sheets("B")
    If .Range("D5") = "" Then Exit Sub
    lastRowB = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
    bShtArr3 = .Range("C5:C" & lastRowB)
    bShtArr4 = .Range("D5:D" & lastRowB)
    bShtArr6 = .Range("F5:F" & lastRowB)
    bShtArr8 = .Range("H5:H" & lastRowB)
    .Range("C5:D" & lastRowB & ",F5:F" & lastRowB & ",H5:H" & lastRowB).ClearContents
    Dim チェック()
    ReDim チェック(1 To UBound(aShtArr1) - 1)
    Dim k As Long, i As Long, j As Long
    Dim quantity As Long, RowCount As Integer
    Dim flag As Boolean
    k = 5        '行目から
    For i = 1 To UBound(bShtArr4) - 1        'Bシートデータでループ
        flag = False: RowCount = 0: quantity = 0        '初期値
        For j = 1 To UBound(aShtArr1) - 1      'Aシートデータをループ

全部書き直すの面倒なのでやっつけ感ありありです
IFやForなどで配列を作るなど書き替えてくださいね
（見えない列の内容によりますが範囲を拡張して一度に出力するような処理が良いと思います）

Qchan1962 · Answer

データをVariant配列に入れていますが個人的な事情です
作り直してみましたが行先をキーにはしていません
いずれにしましても自身で改修できないと意味ないかもですね

Sub test()
Dim aShtArr1
Dim aShtArr3, aShtArr4
Dim aShtArr7, aShtArr8
Dim lastRowA As Long
With Sheets("A")
    lastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
    aShtArr1 = .Range("A5:A" & lastRowA)
    aShtArr3 = .Range("C5:C" & lastRowA)
    aShtArr4 = .Range("D5:D" & lastRowA)
    aShtArr7 = .Range("G5:G" & lastRowA)
    aShtArr8 = .Range("H5:H" & lastRowA)
End With
Dim bShtArr3, bShtArr4, bShtArr6, bShtArr8
Dim lastRowB As Long
With Sheets("B")
    lastRowB = .Cells(.Rows.Count, "D").End(xlUp).Row
    bShtArr3 = .Range("C5:C" & lastRowB)
    bShtArr4 = .Range("D5:D" & lastRowB)
    bShtArr6 = .Range("F5:F" & lastRowB)
    bShtArr8 = .Range("H5:H" & lastRowB)
    .Range("C5:D" & lastRowB & ",F5:F" & lastRowB & ",H5:H" & lastRowB).ClearContents

Dim チェック()
    ReDim チェック(1 To UBound(aShtArr1))
    Dim k As Long, i As Long, j As Long
    Dim quantity As Long, RowCount As Integer
    Dim flag As Boolean
    k = 5        '行目から
    For i = 1 To UBound(bShtArr4)        'Bシートデータでループ
        flag = False: RowCount = 0: quantity = 0        '初期値
        For j = 1 To UBound(aShtArr1)        'Aシートデータをループ
            If aShtArr1(j, 1) = bShtArr4(i, 1) Then        '①
                If aShtArr7(j, 1) = "" And aShtArr8(j, 1) = "" Then        '②
                    If チェック(j) = "" Or チェック(j) = "予備" Then        'Aデータ簡易フラグ
                        quantity = quantity + aShtArr4(j, 1)
'③Bシート8列目の数量に合う個数まで
                        If quantity <= bShtArr8(i, 1) Then
'④下記を転記
                            If flag = False Then
                                .Cells(k, "C").Value = bShtArr3(i, 1)
                                .Cells(k, "D").Value = bShtArr4(i, 1)
                                .Cells(k, "F").Value = bShtArr6(i, 1)
                                .Cells(k, "H").Value = bShtArr8(i, 1)
                                flag = True
                            End If
                            チェック(j) = "〇"
                            .Cells(k, "A") = "〇"
                            .Cells(k, "J") = aShtArr3(j, 1)
                            .Cells(k, "K") = aShtArr4(j, 1)
                            k = k + 1
                        Else
'各車種名毎に､それぞれ最大4つのデータを､
'④で転記した続きの製造NOを､予備としてAシートから下記を転記
                            RowCount = RowCount + 1
                            If RowCount <= 4 Then
                                チェック(j) = "予備"
                                .Cells(k, "A") = "予備"
                                .Cells(k, "J") = aShtArr3(j, 1)
                                .Cells(k, "K") = aShtArr4(j, 1)
                                k = k + 1
                            End If
                            If RowCount = 5 Then k = k + 1: Exit For
                        End If
                    End If
                Else
'⑪AシートのG列またはH列に"○"がある場合⑩
'⑩で転記した続きの製造NOを、×としてAシートから下記を転記
                    If チェック(j) <> "×" Then
                        チェック(j) = "×"
                        If flag = False Then
                            .Cells(k, "C").Value = bShtArr3(i, 1)
                            .Cells(k, "D").Value = bShtArr4(i, 1)
                            .Cells(k, "F").Value = bShtArr6(i, 1)
                            .Cells(k, "H").Value = bShtArr8(i, 1)
                            flag = True
                        End If
                        .Cells(k, "A") = "×"
                        .Cells(k, "J") = aShtArr3(j, 1)
                        .Cells(k, "K") = aShtArr4(j, 1)
                        k = k + 1
                    End If
                End If
            End If
        Next
' 不足の場合
        If quantity <= bShtArr8(i, 1) Then
'    MsgBox bShtArr6(i, 1) & "の" & bShtArr4(i, 1) & " が" & bShtArr8(i, 1) - quantity & "不足"
            .Cells(k, "A") = "×不足" & bShtArr8(i, 1) - quantity
            k = k + 2
        End If
    Next
End With
End Sub

Qchan1962 · Answer

こんばんは
補足が５つ目の補足がブラウザBraveの為か表示されていなくクロムでようやく確認しました
もう一度明日午後（時間が取れるか微妙ですが）に考えてみますので
Ⅰ　＞③Bシート6列目の数量に合う個数まで　の意味と
Ⅱ　＞Aシートの4列目各車種名毎に、それぞれ最大4つのデータを、
の意味・・・（よく理解できません、矛盾しそうで・・・）
Ⅲ　＞⑩で転記した続きの製造NOを、×としてAシートから下記を転記
Ⅳ　条件としてaシートは製造№でそうとされているで良いですよね

例　クラウンの受注数が10000の場合どうなるの？
在庫数？が受注数に満たない場合どうなるの？　　など

また、〇や×などの出力先
説明は列名なので　製造NO　などは列名などでご説明頂けますか
クロムから投稿

Qchan1962 · Answer

こんにちは
本日は連休の合間の仕事が立て込んでおりまして・・中々目を通す事が出来ませんでした
＃４のコードはAシート5列目をフラグ代わりに使用しましたが
○や予備、×の定義が良く分からないです・・・　が　
Bシートの上書きする等の使い方から　何だかの方法でAシートBシートに新しいデータを入れ加工すれば良いのかなと思いました

A、BデータはVBA実行の度、新しいデータである事を前提にしたサンプルです
コードは煮詰めれば分かり易くなりそうですが　そのあたりはお任せします
（ロジック的にもべたでなく他の方法がありそうですね）

Option Explicit
'モジュールレベル
Dim B行先, B車種名, B受注番号, B受注数
Dim i As Long, j As Long, k As Long
Dim orderCont As Long, flag As Boolean, chk()

Sub TENNKI_02()
    Dim lastRowA As Long, lastRowB As Long
    lastRowA = Sheets("A").Cells(Rows.Count, 1).End(xlUp).Row

With Sheets("B")
        lastRowB = .Cells(Rows.Count, "D").End(xlUp).Row
        'Bシートデータを一旦配列に入れる
        B行先 = .Range("C5:C" & lastRowB)
        B車種名 = .Range("D5:D" & lastRowB)
        B受注番号 = .Range("F5:F" & lastRowB)
        B受注数 = .Range("H5:H" & lastRowB)
        ReDim chk(5 To lastRowA)
        '元データをクリアー
        .Range("C5:D" & lastRowB, "F5:H" & lastRowB).ClearContents
        k = 5  '始まり行
        For j = 1 To UBound(B車種名)    'Bシートデータでループ
            orderCont = B受注数(j, 1)
            For i = 5 To lastRowA
                If B車種名(j, 1) = Sheets("A").Cells(i, "A").Value Then
                    Select Case chk(i)
                        Case ""
                            If orderCont > 0 Then
                                chk(i) = "○"
                                Call output_process(False)
                                k = k + 1
                            Else
                                chk(i) = "予備"
                                .Cells(k, "A").Value = chk(i)
                                .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
                                .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
                                orderCont = orderCont - Sheets("A").Cells(i, 4)
                                k = k + 1
                            End If
                        Case "予備"
                            If orderCont > 0 Then
                                chk(i) = "○"
                                Call output_process(False)
                                k = k + 1
                            Else
                                chk(i) = "予備"
                                Call output_process(False)
                                k = k + 1
                            End If
                        Case "×"
                            Call output_process(True)
                            k = k + 1
                    End Select
                Else
                    If orderCont > 0 And flag = True Then
                        .Cells(k, "A").Value = orderCont & ":不足"
                        chk(i - 1) = "×"
                        k = k + 1
                        Exit For
                    End If
                End If
            Next
            flag = False
            k = k + 1
        Next
    End With
End Sub

Sub output_process(endFlag As Boolean)
Dim stock_quantity As Long
If endFlag = True Then
stock_quantity = 0
Else
stock_quantity = Sheets("A").Cells(i, 4)
End If
With Sheets("B")
    If flag = False Then
        .Cells(k, "C").Value = B行先(j, 1)
        .Cells(k, "D").Value = B車種名(j, 1)
        .Cells(k, "F").Value = B受注番号(j, 1)
        .Cells(k, "H").Value = B受注数(j, 1)
        .Cells(k, "A").Value = chk(i)
        .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
        .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
        orderCont = orderCont - stock_quantity
        flag = True
    Else
        .Cells(k, "A").Value = chk(i)
        .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
        .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
        orderCont = orderCont - stock_quantity
    End If
End With
End Sub

初心者ですが何か。 · Answer

直接の回答ではないですが。
画像添付は知恵袋の方が扱いやすいと感じます。
拡大してもソコソコ見えますし。
昔ならサンプルＢｏｏｋをアップして回答を貰うと言うのもありましたけど、危険視されたのかその方法を辞めたサイト多いですね。

Qchan1962 · Answer

よく見るとBシートA列は何ぞや・・・と
丸や予備がどこにあるのかわからないけれど
AシートのE列をお借りして新たに書くと（纏めていませんが）下記のようになるかな
いずれにしましても自身で改修できないと意味ないかもです
Sub TENNKI_01()
    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim 車種名 As String

lastRowA = Sheets("A").Cells(Rows.count, 1).End(xlUp).Row
    Dim B行先, B車種名, B受注番号, B受注数
    Dim flag As Boolean, chk As Range
    With Sheets("B")
        lastRowB = .Cells(Rows.count, "D").End(xlUp).Row
        '一旦配列に入れる
        B行先 = .Range("C5:C" & lastRowB)
        B車種名 = .Range("D5:D" & lastRowB)
        B受注番号 = .Range("F5:F" & lastRowB)
        B受注数 = .Range("H5:H" & lastRowB)
        '元データをクリアー
        .Range("C5:D" & lastRowB, "F5:H" & lastRowB).ClearContents
        k = 5
        For j = 1 To UBound(B車種名)    'Bシートデータでループ
            For i = 5 To lastRowA
                車種名 = Sheets("A").Cells(i, "A").Value
                Set chk = Sheets("A").Cells(i, 5)
                If B車種名(j, 1) = 車種名 Then
                    Select Case chk.Value
                        Case ""
                            If B受注数(j, 1) >= 0 Then
                                chk.Value = "○"
                            Else
                                chk.Value = "予備"
                            End If
                            If flag = False Then
                                .Cells(k, "C").Value = B行先(j, 1)
                                .Cells(k, "D").Value = B車種名(j, 1)
                                .Cells(k, "F").Value = B受注番号(j, 1)
                                .Cells(k, "H").Value = B受注数(j, 1)
                                .Cells(k, "A").Value = Sheets("A").Cells(i, 5).Value
                                .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
                                .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
                                B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
                                flag = True
                            Else
                                .Cells(k, "A").Value = Sheets("A").Cells(i, 5).Value
                                .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
                                .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
                                B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
                            End If
                            k = k + 1
                        Case "予備"
                            If B受注数(j, 1) >= 0 Then chk.Value = "○"
                            If flag = False Then
                                .Cells(k, "C").Value = B行先(j, 1)
                                .Cells(k, "D").Value = B車種名(j, 1)
                                .Cells(k, "F").Value = B受注番号(j, 1)
                                .Cells(k, "H").Value = B受注数(j, 1)
                                .Cells(k, "A").Value = Sheets("A").Cells(i, 5).Value
                                .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
                                .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
                                B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
                                flag = True
                            Else
                                .Cells(k, "A").Value = Sheets("A").Cells(i, 5).Value
                                .Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
                                .Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
                                B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
                            End If
                            k = k + 1
                    End Select
                End If
            Next
            flag = False
            k = k + 1
        Next
    End With
    
End Sub

Qchan1962 · Answer

シートを分けた時の配置が判らないので
ご質問のシートを分けない方法の例です
（配置、コード内容を読み違えていたら修正してください）
すみませんが、非表示列などがある為　検証データを作成をしませんでした
デバッグはご自身で行って下さい

Sub TENNKI_01()
Dim lastRowA As Long
Dim lastRowB As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim 車種名 As String

lastRowA = Sheets("A").Cells(Rows.count, 1).End(xlUp).Row
lastRowB = Sheets("B").Cells(Rows.count, "D").End(xlUp).Row
'一旦配列に入れる
Dim B行先, B車種名, B受注番号, B受注数
B行先 = Sheets("B").Range("C5:C" & lastRowB)
B車種名 = Sheets("B").Range("D5:D" & lastRowB)
B受注番号 = Sheets("B").Range("F5:F" & lastRowB)
B受注数 = Sheets("B").Range("H5:H" & lastRowB)
'元データをクリアー
Range("C5:D" & lastRowB, "F5:H" & lastRowB).ClearContents
Dim flag As Boolean

k = 5
For j = 1 To UBound(B車種名)  'Bシートデータでループ
For i = 5 To lastRowA
車種名 = Sheets("A").Cells(i, "A").Value
If B車種名(j, 1) = 車種名 And B受注数(j, 1) >= 0 Then
If flag = False Then
Sheets("B").Cells(k, "C").Value = B行先(j, 1)
Sheets("B").Cells(k, "D").Value = B車種名(j, 1)
Sheets("B").Cells(k, "F").Value = B受注番号(j, 1)
Sheets("B").Cells(k, "H").Value = B受注数(j, 1)
Sheets("B").Cells(k, "A").Value = Sheets("A").Cells(i, 8).Value
Sheets("B").Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
Sheets("B").Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
flag = True
Else
Sheets("B").Cells(k, "A").Value = Sheets("A").Cells(i, 8).Value
Sheets("B").Cells(k, "J").Value = Sheets("A").Cells(i, 3).Value
Sheets("B").Cells(k, "K").Value = Sheets("A").Cells(i, 4).Value
B受注数(j, 1) = B受注数(j, 1) - Sheets("A").Cells(i, 4)
End If
k = k + 1
End If
Next
flag = False
k = k + 1
Next
End Sub

Qchan1962 · Answer

A、Bシートデータに基づき　データを加工（並び替えなど）して
データのあるBシートの同じセルに出力するようなロジックは
Bシートデータを配列に一時保存する等の必要が生じる為
出力先をCシートなど新たなシートにした方が良いように思います
（示されているコードですと行の挿入などが必要になると共にlastRowBなど正しく処理できないものと存じます）

繰り返し使用するVBAではデータベースシート、処理に必要なデータシート、結果を出力するシートなどに分けると良いでしょう

もし、他のシートに書き出すのに問題が生じる場合は
Bシートの必要データを配列に入れてデータ保持をして
予め同品名出荷先個数分行を挿入もしくは、加工結果を配列に代入して出力するようにすれば良いと思います（非表示列の値に問題が無ければ・・・）

以前同様のご質問があった記憶がありますが探すのが面倒で探していません
解決していたような気がしますがどうなったのかな

Qchan1962 · Answer

こんにちは
③について不明なので読み進めていませんが
＞このコードではエラーも出ず、全く転記できません。
と言う事で　ステップインで（F8）実行してロジックを確かめて見るのが良いのではないかと思います

画像については小さくて見えませんので１シートずつ補足などを利用して掲示するのが良いでしょう

私が回答できるか分かりませんが、確認してみてください

VBAで、シート間の転記するコードをFOR～NEXTで教えてください。

こんにちは

データをVariant配列に入れていますが個人的な事情です

こんばんは

こんにちは

直接の回答ではないですが。

よく見るとBシートA列は何ぞや・・・と

シートを分けた時の配置が判らないので

A、Bシートデータに基づき データを加工（並び替えなど）して

こんにちは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

A、Bシートデータに基づき　データを加工（並び替えなど）して