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

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

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

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

code1

Macro
1               With wsAcq
2                Dim n As Long                  'ループで使用します。
3                Dim m As Long                  'ループで使用します。
4                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
5                
6                        For n = i + 3 To ec1   '①
7                    
8                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
9                            
10                                
11                                For m = i + 3 To ec1
12                                    wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value   '②
13                                Next m
14                                
15
16                            lngRowsNo = lngRowsNo + 1
17                        
18                        Next n
19

code2

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

コード全体

Macro
1Sub sample1()
2
3    Dim lngRowsNo       As Long                     ' 書きこむ位置
4    Dim lngSheetIndex   As Long                     ' シートの番号
5    Dim strFile         As String                   ' Excelファイルの場所
6    Dim xlsAcq          As New Excel.Application    ' 取得側Excel
7    Dim wbAcq           As Workbook                 ' 取得側Excelブック
8    Dim wsAcq           As Worksheet                ' 取得側Excelシート
9    Dim wsSet           As Worksheet                ' 設定側Excelシート
10    Const strPath       As String = "パスの指定"
11    Set wsSet = ActiveSheet
12    Dim i As Long
13
14
15     strFile = Dir(strPath & "*.xls")
16    lngRowsNo = 2
17    Do Until strFile = ""
18        '----- Excelブックを開く
19        Set wbAcq = Workbooks.Open(strPath & strFile)
20
21        '----- シートを検索
22        For lngSheetIndex = 1 To wbAcq.Worksheets.Count
23            '----- 「更新」シートを検索
24            If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
25                '----- 「更新」シートを変数へ登録
26                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
27                '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
28                With wsAcq
29                Dim n As Long                  'ループで使用します。
30                Dim m As Long                  'ループで使用します。
31                Dim ec1 As Long               '各開発の一番下の担当者のセルを取得
32                
33                For i = 1 To .UsedRange.Rows.Count
34                
35                    If Left(.Cells(i, 2).Value, 2) = "開発" Then
36                    
37                     ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
38                     'データの入っているところまでループさせる (その時、開発名を転記)
39                     
40                     ec1 = .Cells(i + 3, 3).End(xlDown).Row
41                        For n = i + 3 To ec1
42                    
43                            wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
44                            
45                                For m = i + 3 To ec1
46                                    wsSet.Cells(lngRowsNo, 3).Value = .Cells(i + 3, 3).Value
47                                Next m
48                                
49
50                            lngRowsNo = lngRowsNo + 1
51                        
52                        Next n
53                    
54                    End If
55                Next i
56                End With
57                '----- 書きこむ位置移動
58               
59                '----- 検索の終了
60                Exit For
61            End If
62        Next lngSheetIndex
63
64        '----- シート参照の解放
65        Set wsAcq = Nothing
66        '----- ブックを閉じる
67        wbAcq.Close Savechanges:=False
68        '----- 次のファイルへ
69        strFile = Dir()
70    Loop
71
72    '----- Excelへの参照の解放
73    Set xlsAcq = Nothing
74
75End Sub

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

転記元

転記先

y_waiwai

2020/09/19 03:06

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

icecleam

2020/09/19 03:11

For「 n」 = i + 3 To ec1 '① かっこでくくった部分のことです。

hatena19

2020/09/19 03:49

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

icecleam

2020/09/19 04:13

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

Usirow

2020/09/19 06:10 編集

もしかして、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

2020/09/19 06:13

そうですね 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_

2020/09/19 06:18

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

Usirow

2020/09/19 06:31

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

行動規範の内容に同意します

回答2件

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

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

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

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

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

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

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

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

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

ExcelVBA
1'シートの存在確認
2Private Function ChkExistenceSheet(ByRef wb As Workbook, _
3                                   ByVal s As String, _
4                                   ByRef ws As Worksheet) As Boolean
5    On Error Resume Next
6    Set ws = wb.Worksheets(s)
7    On Error GoTo 0
8    If ws Is Nothing Then Exit Function
9    
10    ChkExistenceSheet = True
11End Function
12
13'期待しているような表があるか確認し、対象の表のセル範囲を取得
14'※各表は空白行で区切られていることを前提にしているので、
15'そうなってない場合はこのプロシージャのみ変更すること
16Private Function GetTable(ByRef ws As Worksheet, _
17                          ByRef Rng As Range) As Boolean
18    Const myNum As Long = 2
19    Dim r As Range
20    Dim i As Long, j As Long
21    
22    On Error Resume Next
23    Set Rng = ws.Columns(1).SpecialCells(xlCellTypeConstants)
24    On Error GoTo 0
25    If Rng Is Nothing Then Exit Function
26    j = Rng.Areas.Count
27    If j <= myNum Then Exit Function
28    
29    '1番目の表は除外
30    Set r = Rng.Areas(2)
31    For i = myNum To j
32        Set r = Union(r, Rng.Areas(i))
33    Next
34    Set Rng = r
35    
36    GetTable = True
37End Function

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

ExcelVBA
1'期待している項目が期待している位置にあるか確認しコピーすべきセル範囲を取得
2Private Function GetItemData(ByRef rngTarget As Range, _
3                             ByVal s As String, _
4                             ByRef rngCopyTo As Range) As Boolean
5    Dim sName As String
6    Dim a As Range
7    Dim c As Range
8    Dim rngData As Range
9    
10    '飛び飛びのセル範囲(各表)毎に繰り返し
11    For Each a In rngTarget.Areas
12        If a.Cells(1).Value Like "開発*" Then
13            Set rngData = Intersect(a, a.Offset(3, 2))
14            '列ごとに繰り返し
15            For Each c In rngData.Columns
16                If c.Cells(0, 1).Value = s Then
17                    If rngCopyTo Is Nothing Then
18                        Set rngCopyTo = c
19                    Else
20                        Set rngCopyTo = Union(rngCopyTo, c)
21                    End If
22                End If
23            Next
24        End If
25    Next
26    If rngCopyTo Is Nothing Then Exit Function
27    
28    GetItemData = True
29End Function
30

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

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

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

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

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

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

投稿2020/09/19 10:46

mattuwan

総合スコア2163

ベストアンサー

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

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

vba
1
2'前略
3
4                Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
5    '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
6    With wsAcq
7        For i = 1 To .UsedRange.Rows.Count    '行移動ループ
8
9            Dim depName As String    '開発名
10            depName = .Cells(i, 2).Value
11
12            If Left(depName, 2) = "開発" Then
13
14                ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
15
16                Dim ec1 As Long         '各開発の一番下の担当者のセルを取得
17                ec1 = .Cells(i + 3, 3).End(xlDown).Row
18                Dim DataRowCount As Long    'データ行数を取得
19                DataRowCount = ec1 - i - 2
20
21                '行ループせずに一気に代入
22                wsSet.Cells(lngRowsNo, 1).Resize(DataRowCount).Value = _
23                        strFile    'ファイル名
24                wsSet.Cells(lngRowsNo, 2).Resize(DataRowCount).Value = _
25                        depName  '開発名
26                wsSet.Cells(lngRowsNo, 3).Resize(DataRowCount).Value = _
27                        .Cells(i + 3, 3).Resize(DataRowCount).Value    '担当者
28
29                Dim c As Long    '列移動ループ
30                For c = 1 To 4
31                    wsSet.Cells(lngRowsNo, c + 3).Resize(DataRowCount).Value = _
32                            .Cells(i + 3, 2 + c * 3).Resize(DataRowCount).Value
33                Next
34
35                lngRowsNo = lngRowsNo + ec1
36            End If
37        Next i
38    End With
39    '----- 書きこむ位置移動