質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.04%

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

受付中

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 1,299

score 3

前提・実現したいこと

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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • kai_keitai

    2020/05/29 12:38

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

    キャンセル

  • 2134

    2020/06/03 13:59

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

    キャンセル

回答 1

+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上で、ワークシート関数で関数を取得してデータがあるのか無いのか判断もできるでしょう。

Applicatiuon.WoerksheetFunction.CountA(Rangeオブジェクト)


これで、件数が取得できます。

やり方は、自由です。

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.04%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • トップ
  • VBAに関する質問
  • Excelファイル間のデータ転記(転記元ファイルの表の行数がファイルによって異なる)