Excelファイル間のデータ転記（転記元ファイルの表の行数がファイルによって異なる）

Question

前提・実現したいこと

ExcelファイルからExcelファイル（一覧）へデータを転記するプログラムを作成しました。
（複数の転記元ファイルのデータを、一覧ファイルへ転記）

転記元ファイルのAシート、Bシートの一部セル　→　転記先一覧ファイルのZシート
転記元ファイルのBシートは表形式になっており、表の行数はファイルによって異なります。
Bシートに2行以上データがある場合は、Zシートにもその行数分データを転記したいのですが、
その方法がわからず、困っています。

また、Bシートの表にデータがない場合は、転記処理を行わないようにしたいのですが、
これも実現できておりません。

Aシートのデータをa、Bシート表1行目のデータをb1、2行目のデータをb2とすると、
下記のようにデータを転記するマクロを作成したいです。

転記先Zシート（C列以降にもデータを転記しますが、説明の便宜上割愛します）
' A B
1 a b1
2 a b2
3　（別ファイルも同様に繰り返す）

Bシートの表が1行のときに、転記するマクロは作成できたため、
そのソースコードを記載致しますので、アドバイスをいただきたいです。
VBA初心者のため拙いソースコードがあり、改善できる部分もありましたら、併せてご指摘をいただけますと幸いです。
わかりにくい部分もあるかと思いますが、宜しくお願い致します。

該当のソースコード

Option Explicit

Dim mFSO As FileSystemObject

Sub 一覧作成()
    Dim rngList As Range
    Dim vrtSubjectList As Variant

    'シートの非表示行を表示する
    Cells.EntireColumn.Hidden = False
    
    'フィルターをクリア
    If Worksheets("一覧").FilterMode Then
        Worksheets("一覧").ShowAllData
    End If

    '自動更新しないように設定
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'FileSystemObjectを呼び出す
    Set mFSO = New FileSystemObject

   '一覧表のセル範囲取得
    Set rngList = ThisWorkbook.Worksheets("一覧").Range(Cells(2, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))

    '一覧表クリア
    InitializeTable rngList

    'ファイルのリストを取得
    vrtSubjectList = Get_UpdatedSubjectList(rngList)

    'データの転記
    SetUpdated vrtSubjectList, rngList

    '作成した一覧表をソート
    Sort rngList

    '項番採番
    Reference rngList

    '画面描画を再開
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

    MsgBox "一覧表を作成しました。"
    
End Sub

'一覧表をクリア
Private Sub InitializeTable(ByRef rngList As Range)
    Dim rngNotBlank As Range

    Set rngList = ThisWorkbook.Worksheets("一覧").Range(Cells(2, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))

    With rngList
        If rngList.Rows.Count > 1 Then
            On Error Resume Next
            
            'C列がBlankではないセルを取得
            Set rngList = ThisWorkbook.Worksheets("一覧").Range(Cells(3, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))
            Set rngNotBlank = rngList.Columns(3).SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
            If rngNotBlank Is Nothing Then Exit Sub

            '一覧表のデータをクリア
            rngNotBlank.EntireRow.ClearContents
            
        End If
        Set rngList = rngList.CurrentRegion
    End With
End Sub

'ファイルのフルパスのリストを取得
Private Function Get_UpdatedSubjectList(ByRef rngList As Range) As Variant
    Dim WSF As WorksheetFunction
    Dim myFolder As folder
    Dim myFile As file
    Dim strPath As String
    Dim vrtNewList() As Variant
    Dim ix As Long

    Dim intPos As Long

    ReDim vrtNewList(1 To 50000)
    Set WSF = Application.WorksheetFunction

    strPath = ThisWorkbook.Path

    '一覧と同じフォルダにあるフォルダに対して繰り返し処理
    For Each myFolder In mFSO.GetFolder(strPath).SubFolders
        'フォルダ内のファイルに対して繰り返し処理
        For Each myFile In myFolder.Files
            ix = ix + 1
            vrtNewList(ix) = myFile.Path
        Next
    Next

    ReDim Preserve vrtNewList(1 To ix)
    Get_UpdatedSubjectList = vrtNewList
End Function

'データの転記
Private Sub SetUpdated(ByVal vrtSubjectList As Variant, ByRef rngList As Range)
    Dim f As Variant
    Dim ix, s As Long
    Dim rng, As Range
    Dim vrtNewList() As Variant
    ReDim vrtNewList(LBound(vrtSubjectList) To UBound(vrtSubjectList), 1 To 5)

    For Each f In vrtSubjectList
        ix = ix + 1
        '更新しないでファイルを開く
        With Workbooks.Open(f, UpdateLinks:=0, ReadOnly:=True)
            '自動計算を有効化（正しい管理番号を取得するため）
            With Application
                .Calculation = xlCalculationAutomatic
            End With

            For s = 1 To Worksheets.Count
                If Worksheets(s).Name = "B" Then
                    Worksheets("B").Activate
                    Set rng = Worksheets("B").Range(Cells(3, 2), Cells(Cells(Rows.Count, 5).End(xlUp).Row, Cells(3, Columns.Count).End(xlToLeft).Column))
                    
                    '一覧に記載があるか判定
                    If rng.Rows.Count > 1 Then
                            With .Sheets("B")
                                vrtNewList(ix, 1) = .Range("D4").Value
                                vrtNewList(ix, 3) = .Range("H4").Value
                                vrtNewList(ix, 4) = .Range("I4").Value
                                vrtNewList(ix, 5) = .Range("J4").Value
                            End With
                            With .Sheets("A")
                                vrtNewList(ix, 2) = .Range("F7").Value
                            End With
                        Next
                    End If
                End If
            Next
            .Close False
        End With
    Next

    'データを一覧に転記
    With rngList
        Set rngList = .Cells(3, 2).Resize(UBound(vrtNewList, 1), UBound(vrtNewList, 2))
    End With
    rngList.Value = vrtNewList

End Sub

'作成した一覧表をソート
Private Sub Sort(ByRef rngList As Range)

    Set rngList = ThisWorkbook.Worksheets("一覧").Range(Cells(2, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))

    'ソート
    With rngList
        rngList.Sort Key1:=Range("B3"), Order1:=xlAscending, _
                     Key2:=Range("C3"), Order2:=xlAscending, Header:=xlYes, _
                     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With

End Sub

'項番採番
Private Sub Reference(ByRef rngList As Range)
    Dim L, n As Integer

    Set rngList = ThisWorkbook.Worksheets("一覧").Range(Cells(3, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))

    While rngList.Cells(L, 3).Value <> ""
        rngList.Cells(L, 1).Value = n
        L = L + 1
        n = n + 1
    Wend

End Sub

Comments

[kai_keitai]

お使いのExcelのバージョンを教えてください。
バージョンによっては、VBAを使う必要が無い可能性がある為です。

[2134]

コメントいただきありがとうございます。
Microsoft 365 MSO 32ビット版を利用しています。
しかし、私だけが上記一覧を作成する訳ではなく、一覧を作成する人によってExcelのバージョンは異なるので、バージョンによって作成できる/できない、操作が異なることは避けたいと思っています。

Answer 1

バージョンは、古い可能性があるとのことで、VBAが一番の最善の手段ですね。

ソースコードを見ると、構造化されており、それなりに経験があると思いますので、
助言をしますので、自力で解決下さい。
まず、セル範囲を取得するときに、

Range(Cells(2, 1), Cells(Cells(Rows.Count, 3).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column))

と書かれているようです。
子の場合、データ件数が無い時、空白も拾ってしまい、大変なのでしょう。

実務が見えないので、解決できるかどうか不明瞭ですが、
単純にセル範囲を取得するのであれば、

Set rngList = ActiveCell.CurrentRegion
```
とする方法がとれます。
Rangeオブジェクトには、Countプロパティが取得できるので、
データ数が列数で割り算することによって、件数の取得が可能です。


データ件数で、判断ができるのであれば、
VBA上で、ワークシート関数で関数を取得してデータがあるのか無いのか判断もできるでしょう。
```EXCEL VBA
Applicatiuon.WoerksheetFunction.CountA(Rangeオブジェクト)
```
これで、件数が取得できます。

やり方は、自由です。

ちなみに、集計担当者？が、Microsoft 365 からの Excel ProPlusであれば、VBAは不要と考えます。
参考までに、画像のみ貼り付けします。
![イメージ説明](5f7339de5dcfd765bfc52671909808c1.jpeg)
本来なら、ワークシート上にテーブルを定義するのが理想です。
さらに、データフォーマットを統一するとかポイントが必要ですが、VBAは不要だし、
PowerQuery上で、ある程度、データの編集が可能です。