VBA マクロの２重のループ処理の書き方

Question

以下のコードcode1で①のnの値に干渉せずに②のi+3をループさせたいです。

一度code2のように記載したのですが、もちろんそれだと①のnも同時に+1されてしまいます。
別の変数を用意して、mとnを別でループさせたいのですが書き方がわからずうまく実装できませんでしたので、その書き方を教えていただきたいです。
よろしくお願いします。

コード全体の大まかな仕様と、ソースは最下部に参考として、載せておきます。（参考までに）

code1

               With wsAcq
                Dim n As Long                  'ループで使用します。
                Dim m As Long                  'ループで使用します。
                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
                
                        For n = i + 3 To ec1   '①
                    
                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
                            
                                
                                For m = i + 3 To ec1
                                    wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value   '②
                                Next m
                                

                            lngRowsNo = lngRowsNo + 1
                        
                        Next n

code2

wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value '②
i = i + 1

コード全体

Sub sample1()

    Dim lngRowsNo       As Long                     ' 書きこむ位置
    Dim lngSheetIndex   As Long                     ' シートの番号
    Dim strFile         As String                   ' Excelファイルの場所
    Dim xlsAcq          As New Excel.Application    ' 取得側Excel
    Dim wbAcq           As Workbook                 ' 取得側Excelブック
    Dim wsAcq           As Worksheet                ' 取得側Excelシート
    Dim wsSet           As Worksheet                ' 設定側Excelシート
    Const strPath       As String = "パスの指定"
    Set wsSet = ActiveSheet
    Dim i As Long


     strFile = Dir(strPath & "*.xls")
    lngRowsNo = 2
    Do Until strFile = ""
        '----- Excelブックを開く
        Set wbAcq = Workbooks.Open(strPath & strFile)

        '----- シートを検索
        For lngSheetIndex = 1 To wbAcq.Worksheets.Count
            '----- 「更新」シートを検索
            If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
                '----- 「更新」シートを変数へ登録
                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
                With wsAcq
                Dim n As Long                  'ループで使用します。
                Dim m As Long                  'ループで使用します。
                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
                
                For i = 1 To .UsedRange.Rows.Count
                
                    If Left(.Cells(i, 2).Value, 2) = "開発" Then
                    
                     ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
                     'データの入っているところまでループさせる (その時、開発名を転記)
                     
                     ec1 = .Cells(i + 3, 3).End(xlDown).Row
                        For n = i + 3 To ec1
                    
                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
                            
                                For m = i + 3 To ec1
                                    wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value
                                Next m
                                

                            lngRowsNo = lngRowsNo + 1
                        
                        Next n
                    
                    End If
                Next i
                End With
                '----- 書きこむ位置移動
               
                '----- 検索の終了
                Exit For
            End If
        Next lngSheetIndex

        '----- シート参照の解放
        Set wsAcq = Nothing
        '----- ブックを閉じる
        wbAcq.Close Savechanges:=False
        '----- 次のファイルへ
        strFile = Dir()
    Loop

    '----- Excelへの参照の解放
    Set xlsAcq = Nothing

End Sub

■マクロの概要
以下の画像のようにブックからブックへ転記をしたいです。
その時、転記元のエクセルファイル（拡張子はxls）が格納されているフォルダを指定してそのフォルダ内のエクセルファイルすべてに対してに「更新」というシートがあるときだけ以下の画像のように転記を実行したいです。（現在は作成途中で担当者を転記先のように転記したいです。）

転記元

転記先

Comments

[y_waiwai]

①のnってどれのことでしょうか

[icecleam]

For「 n」 = i + 3 To ec1 '①

かっこでくくった部分のことです。

[hatena19]

提示のコードは2重ループになってないし、nはループ内で使ってないし、それ以外の変数の初期化の部分もないし、これでは何がしたくて、何が問題なのかサッパリです。
状況を再現できるコード全体を提示して、どこが想定と違うのか説明してください。

[icecleam]

すみません、今コードの全体と内容の修正を編集として実施しましたので
再度ご確認いただければと思います。

[Usirow]

もしかして、mのループ内でのみ、iの値を+1していき、mのループを抜けたらまた元のiに戻るという処理をしたいのでしょうか？
コードを読む限り、mループ内の i + 3 は 常に m と同値になっているはずなので
wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value '②
→wsSet.Cells(lngRowsNo, 3).Value = .Cells(m, 3).Value '②
とするだけで良さそうに見えます。

[icecleam]

そうですね
mのループだけを回して担当者を行を更新していくようにしたいです。
以下のように修正したら、担当者が開発AではHのみ、開発BではLのみが記載されてしまいました。。
質問のコードだと開発AではAのみ、開発BではIのみが転記されてしまいます。

For m = i + 3 To ec1
wsSet.Cells(lngRowsNo, 3).Value = .Cells(m, 3).Value
Next m

[kuma_kuma_]

よくわからんけど、こういう事？
For lngRow = 1 To .UsedRange.Rows.Count
For lngCol = 1 To .UsedRange.Columns.Count
'.UsedRange.Cells(lngRow, lngCol)
next lngCol
next lngRow

[Usirow]

修正する前も後も、ループ内で書き込み先の行を示す IngRowsNo が一定なので、mループ内で同じセルに上書きし続けてる状態ですね。ステップ実行すればすぐに気付けるはずです。
IngRowsNo になにか変数をくっつけてループ内で加算させてしまえば大丈夫でしょう。

Answer 1

んと、だらだらと、長くて、
ループの入れ子がいっぱい重なっているコードを書いても、
今はいいですが、あとで読んで自分で解読するのも困難かと思います。
こういうときは、
まずは大まかな作業の流れを考えて書きます。

とりあえず大まかにいうと、

「指定のフォルダー内のエクセルファイルを順次開いて、
更新シートの工数の項目を転記」

したいのだと思います。
となると、こんな感じで書けると思います。

Option Explicit

Sub メイン()
    Const cmyPath As String = "フォルダーパスの指定"
    Dim buf As String
    Dim wb As Workbook
    Dim ixRow As Long
    
    '書き込み行番号初期化
    ixRow = 2
    '指定フォルダー内のエクセルファイルの名前を順次取得
    buf = Dir(cmyPath & "*.xls")
    Do Until Len(buf) = 0
        Set wb = Workbooks.Open(cmyPath & buf)
        '更新シートのデータを転記
        MyCopy wb, "更新", "工数", ixRow
        '開いたファイルを保存せずに閉じる
        wb.Close False
    Loop
End Sub

で、「転記」の部分は繰り返し下請けのプロシージャさんを呼び、
下請けのプロシージャに情報を渡して、仕事をやってもらいます。
上記のコードでは、
「MyCopy wb, "更新", "工数", ixRow」
の部分です。
で、その下請けさんがやる作業内容は、

'指定されたシート名のシート上の表を順次コピー
Private Sub MyCopy(ByRef wb As Workbook, _
                   ByVal SheetName As String, _
                   ByVal ItemName As String, _
                   ByRef ixRow As Long)
    Dim ws As Worksheet
    Dim rngTable As Range
    Dim rngCopy As Range
    Dim a As Range
    
    '指定のシートはあるの？（あれば取得、なければプロシージャを抜ける）
    If ChkExistenceSheet(wb, SheetName, ws) = False Then Exit Sub
    'シート上の表は既定の形になっているの？
    If GetTable(ws, rngTable) = False Then Exit Sub
    'セル範囲に指定の項目はあるの？
    If GetItemData(rngTable, ItemName, rngCopy) = False Then Exit Sub
    
    '条件に合致したので転記
    rngCopy.Copy ThisWorkbook.Worksheets(1).Cells(ixRow, "D")
    
    '次の書き込み行番号をセット
    ixRow = ixRow + rngCopy.Rows.Count
End Sub

このような内容かと思います。
で、各各のチェックはそれぞれ専門の孫請けさんにやってもらいます。
で、とりあえず1回（1つのファイル）が終わったら、
メインの元請に戻って次の呼び出しを待ちます。

各孫請けさんの作業は以下のような感じでいいかなと思いました。

'シートの存在確認
Private Function ChkExistenceSheet(ByRef wb As Workbook, _
                                   ByVal s As String, _
                                   ByRef ws As Worksheet) As Boolean
    On Error Resume Next
    Set ws = wb.Worksheets(s)
    On Error GoTo 0
    If ws Is Nothing Then Exit Function
    
    ChkExistenceSheet = True
End Function

'期待しているような表があるか確認し、対象の表のセル範囲を取得
'※各表は空白行で区切られていることを前提にしているので、
'そうなってない場合はこのプロシージャのみ変更すること
Private Function GetTable(ByRef ws As Worksheet, _
                          ByRef Rng As Range) As Boolean
    Const myNum As Long = 2
    Dim r As Range
    Dim i As Long, j As Long
    
    On Error Resume Next
    Set Rng = ws.Columns(1).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If Rng Is Nothing Then Exit Function
    j = Rng.Areas.Count
    If j <= myNum Then Exit Function
    
    '1番目の表は除外
    Set r = Rng.Areas(2)
    For i = myNum To j
        Set r = Union(r, Rng.Areas(i))
    Next
    Set Rng = r
    
    GetTable = True
End Function

で、やっと本題。
今までの作業で、シート上の飛び飛びのセル範囲
(各表のセル範囲）が取得できている（はず）ので、
各表のコピーすべきセル範囲をループして、
取得します。

'期待している項目が期待している位置にあるか確認しコピーすべきセル範囲を取得
Private Function GetItemData(ByRef rngTarget As Range, _
                             ByVal s As String, _
                             ByRef rngCopyTo As Range) As Boolean
    Dim sName As String
    Dim a As Range
    Dim c As Range
    Dim rngData As Range
    
    '飛び飛びのセル範囲(各表)毎に繰り返し
    For Each a In rngTarget.Areas
        If a.Cells(1).Value Like "開発*" Then
            Set rngData = Intersect(a, a.Offset(3, 2))
            '列ごとに繰り返し
            For Each c In rngData.Columns
                If c.Cells(0, 1).Value = s Then
                    If rngCopyTo Is Nothing Then
                        Set rngCopyTo = c
                    Else
                        Set rngCopyTo = Union(rngCopyTo, c)
                    End If
                End If
            Next
        End If
    Next
    If rngCopyTo Is Nothing Then Exit Function
    
    GetItemData = True
End Function

エクセルの機能のコピペを使えば、
飛び飛びのセル範囲でも1度でコピペできるので、
ループの処理を書くことを少しでも減らせます。

個々のセルを読んだり、個々のセルに書きこんだりというようなことは、
処理が重いので、セル範囲でまとめて処理できることは、
できるだけまとめて処理しましょう。
そのためには、意図したセル範囲を特定するための語彙を増やすことが
必要かと思います。
あと、ミスがないとは限らないので、
本題以外の色々なチェックの作業をすることで、
プログラムがエラーで途中で止まることを、
回避する必要があります。
今回のサンプルでは、単純に無視してますが、
想定外のファイルのファイル名などのログを残したい場合は、
また、そのように書き直す必要があります。
このプログラムが上手く完成しても、
想定外のエラー（想定外の操作によるエラー）、
または新しい要望が次々出てきて、
メンテナンスの必要が出てくると思いますので、
常に勉強して、常にメンテナンスをすることになるかと思います。
なので、あとで読んで分かりやすいコードを書くことに、
注力するといいと思います。
たくさんのコードを書いて、たくさんのコードを読むことをお勧めします。

考え方、コードの書き方など
参考になれば。
（変数の命名はいい加減にしてますので、わかりやすいように変更してください。）

あ、最後になりましたが、
コンパイルして、文法はチェックしてますが、
動作確認はしてません。
隠してあるセルの内容もあるようですし、
表毎に空白行で区切ってないようですので、
このまま試してみても期待した結果が得られないかと思います。

ぼくは、
一つのシートに表をたくさん置く場合は、
視認性の面で、必ず空白行を2行くらい入れて（1行でもよい）、
やるし、そうやっておくと、VBAでは各表のセル範囲を、
比較的容易に取得できるので、空白行で区切ります。
そうしておかないと、
icecleamさんの提示のコードのように、
キーワードを繰り返し検索することが必須になると思います。
もちろん、個人の意見が通る環境ではないかも知れませんが、
可能ならばそうした方がVBAで扱いやすいかと思います。
視認性も良くなると思いますし。（個人の意見ですが。）

長々と乱文失礼しました。

Answer 2

転記する工数は4か月分（4列）固定ということでいいですか。

1行ずつループして転記するのではなく、データ行数を取得して、
データ範囲を一気に転記すればどうでしょうか。

'前略

                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
    '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
    With wsAcq
        For i = 1 To .UsedRange.Rows.Count    '行移動ループ

            Dim depName As String    '開発名
            depName = .Cells(i, 2).Value

            If Left(depName, 2) = "開発" Then

                ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し

                Dim ec1 As Long         '各開発の一番下の担当者のセルを取得
                ec1 = .Cells(i + 3, 3).End(xlDown).Row
                Dim DataRowCount As Long    'データ行数を取得
                DataRowCount = ec1 - i - 2

                '行ループせずに一気に代入
                wsSet.Cells(lngRowsNo, 1).Resize(DataRowCount).Value = _
                        strFile    'ファイル名
                wsSet.Cells(lngRowsNo, 2).Resize(DataRowCount).Value = _
                        depName  '開発名
                wsSet.Cells(lngRowsNo, 3).Resize(DataRowCount).Value = _
                        .Cells(i + 3, 3).Resize(DataRowCount).Value    '担当者

                Dim c As Long    '列移動ループ
                For c = 1 To 4
                    wsSet.Cells(lngRowsNo, c + 3).Resize(DataRowCount).Value = _
                            .Cells(i + 3, 2 + c * 3).Resize(DataRowCount).Value
                Next

                lngRowsNo = lngRowsNo + ec1
            End If
        Next i
    End With
    '----- 書きこむ位置移動

Comments

[icecleam]

ご回答ありがとうございます。
上記のコードで、無事に実行することができたのですが、今回の実装はループ処理を使用して実装したいと考えており、もしよければ上記のコードをループを使用して実装した際のものを教えていただきたいです。。
注文が多くて申し訳ないです。。

[hatena19]

列移動には ループ処理 を使用してますが。

[icecleam]

すみません、言葉足らずでした
ファイル名、開発、担当者の部分もという意味でした。。

[hatena19]

他の方のコメントもヒントにがんばってください。

わさわざ複雑なコードかつ重い処理に時間をさいて修正するモチベーションはありません。あしからず。

[icecleam]

承知しました。
ループ処理の箇所はこちらが記載していなかったのが悪いので、質問の内容の回答をいただけ、動作もこちらで確認させていただきましたのでデータ行数を取得して、データ範囲を一気に転記する方法としての回答として、こちらをベストアンサーとさせていただきます。

ご協力いただきありがとうございました。