VBA マクロでexcelのブックからブックに転記する際のソースの作成方法

Question

以下の「現状のソース」を実行すると「現状の実行結果」のように転記が実行されてしまいます
最下部の「転記先」のように開発AがABC・・・と担当者が担当者数分だけ記載され、それが終わると開発Bというふうに転記されるようにしたいのですが、その処理がどうしても不正になってしまうので教えていただきたいです。

「現状のソース」の
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
以降のコードで転記を実行しています。

宜しくお願いします。

現状の実行結果

現状のソース

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

[coco_bauer]

転記元のシートの構造が良くないです。開発Aとか開発Bが、各表の左上というアクセスしにくところに在るのが問題です。
先に、転記元のシートに"開発"の列を加えて、そこに開発Aとかを埋めておけば、転記先と同じ構造になるので処理の見通しが良くなると思いますよ。更に、転記に関係しない転記元シートのF：G列(0がならんている列）等も削ると更に良いと思います。

出来の悪い転記元を、そのまま使おうとするからプログラムが複雑になっているのではないでしょうか？

[icecleam]

すみません、転記元はこのファイル固定でという課題ですので、変更することはできないです。。
せっかくご助言をいただけたのに対応できず申し訳ないです。

Answer 1

転記元の行指定を i で行っていますよね？
しかしnループ内でiの値は変わらないので、結局転記先のIngRowsNoのみが移動して、転記元は毎回 同じセルを読んでいます。
読む限り原因はここのように見えます。

そもそも2重ループする必要がないように思います。
結局nでec1まで回しているので、以下のようにループ1回で書けます。

 For n = i + 3 To ec1

    wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
    wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value

    lngRowsNo = lngRowsNo + 1

Next n

Comments

[icecleam]

ありがとうございます。
上記のソースで、無事実行できました。