ExcelファイルからExcelファイルへの転記マクロ作成（条件付き）

Question

前提・実現したいこと

ExcelファイルからExcelファイルへの転記マクロ作成（条件付き）

以下目的を達成する方法をご教示いただきたいです
エンジニアではないため、プログラミングへの理解が至らない部分もありますが、宜しくお願い致します

【前提】
顧客からの問い合わせをExcelファイルで管理しています（問い合わせ1件につき、ファイル1つ）
問い合わせファイル内には、問い合わせ内容・日時、対応内容・日時などを記載しており、
ファイルは問い合わせへの対応のステータス毎（「未対応」、「対応中」、「対応済み」）
にフォルダに分けています（手作業）

【現状】
これら全てのファイルを一覧にするマクロを作成しました（問い合わせ1件を1レコードとして一覧に転記）

【目的】
問い合わせファイルが増え、マクロの実行に時間がかかるようになったため、
一覧ファイルの特定のカラム（対応日時）が埋まっている場合は転記せず、
空白の場合のみ、問い合わせファイルから転記するようプログラムを修正したいです

【問題】
条件を追加したところ、条件を反映されておらず、【
現状】同様、問い合わせファイル全件が一覧ファイルに転記されてしまいます

【前提条件】
・一覧ファイルは、問い合わせファイルを格納するステータス毎のフォルダと同フォルダです
・一覧ファイルへの転記は、12行目から行います

発生している問題・エラーメッセージ

エラーメッセージはなく、マクロ自体は正常に終了します

該当のソースコード

'※コメントアウトしている箇所は一部伏せさせていただいております

    '変数宣言
    Dim strDefPath As String
    Dim strActiveSheet As String
    Dim strMyBook As String
    Dim fileName As String
    Dim ctrlNum, ny_ctrlNum As String

    '定数宣言
    Const strInSheet As String = "お客様問い合わせファイル"
    Const strDefFlID As String = "問い合わせ"
    Const strTAIOUZUMI = "\30 対応済み"
    Const strTAIOUCHU = "\20 対応中"
    Const strMITAIOU = "\10 未対応"

Public Sub 一覧作成()

    Dim fs As FileSearch
    Dim fso As Object
    Dim file, folder As Variant
    Dim intRet, i, row As Integer
    Dim lngi As Long
    Dim lngOutRow As Long
    Dim cell As Variant

    '一覧作成の実行確認
    intRet = MsgBox("表を最新の状態にします。よろしいですか？", vbOKCancel, "確認")
    If intRet <> vbOK Then
        Exit Sub
    End If

    '自動更新しないように設定
    With Application
        .Calculation = xlCalculationAutomatic
        .MaxChange = 0.001
    End With
    ActiveWorkbook.PrecisionAsDisplayed = False

    'シートの非表示行を表示する
    Cells.Select
    Selection.EntireColumn.Hidden = False

    '画面の更新を止める
    Application.ScreenUpdating = False

　　'★今回の条件追加のために、取得
    '対応完了日（AQ列）が空白の行の管理NOを取得する
    '対応完了日（AQ列）が空白でない行の管理NOを取得する

    For Each cell In Range("AQ12:AQ3000")

If cell = "" Then
            ny_ctrlNum = cell.Offset(0, -39)
        ElseIf cell <> "" Then
            ctrlNum = cell.Offset(0, -39)
        End If
    Next

　　'★今回の条件追加のために以下のように変更
　　　　'変更前：12行目以降すべてクリア
　　　　'変更後：対応完了日が空白の行のみクリア
    '対応完了日（AQ列）が空白の行の値をクリアする
    For Each cell In Range("AQ12:AQ3000")
        If cell = "" Then
            row = Range("AQ12").row
            Rows(row).ClearContents
        End If
    Next

    'ファイルのパスを取得する'
    strMyBook = ActiveWorkbook.Name
    strActiveSheet = ActiveSheet.Name
    Set fso = CreateObject("Scripting.FileSystemObject")

    lngOutRow = 11

    '対応済みフォルダ内の検索
    strDefPath = ActiveWorkbook.Path & strTAIOUZUMI
    For Each file In fso.GetFolder(strDefPath).Files
        lngOutRow = lngOutRow + 1
        intRet = SHEET_PROC(file.Path, strMyBook, lngOutRow)
        If intRet = 1 Then
            lngOutRow = lngOutRow - 1
        ElseIf intRet = 9 Then
            MsgBox "エラーのため強制終了します。"
        End If
    Next

    '対応中フォルダ内の検索
    strDefPath = ActiveWorkbook.Path & strTAIOUCHU
    For Each file In fso.GetFolder(strDefPath).Files
        lngOutRow = lngOutRow + 1
        intRet = SHEET_PROC(file.Path, strMyBook, lngOutRow)
        If intRet = 1 Then
            lngOutRow = lngOutRow - 1
        ElseIf intRet = 9 Then
            MsgBox "エラーのため強制終了します。"
        End If
    Next

    '未対応フォルダ内の検索
    strDefPath = ActiveWorkbook.Path & strMITAIOU
    For Each file In fso.GetFolder(strDefPath).Files
        lngOutRow = lngOutRow + 1
        intRet = SHEET_PROC(file.Path, strMyBook, lngOutRow)
        If intRet = 1 Then
            lngOutRow = lngOutRow - 1
        ElseIf intRet = 9 Then
            MsgBox "エラーのため強制終了します。"
        End If
    Next

    Call set_num

    Range("A3").Select

    MsgBox "一覧作成しました。"

    '画面描画を再開
    Application.ScreenUpdating = True

    Exit Sub

End Sub


Function SHEET_PROC(strInFl As String, strOutBook As String, lngRowOut As Long) As Integer

    Dim strWk As String
    Dim strInBook As String
    Dim intPos As Integer
    Dim wbIn As Workbook

        SHEET_PROC = 9

    'リンクを更新せずにファイルを開く
    Set wbIn = Workbooks.Open(strInFl, 0)

    intPos = InStr(strInFl, strDefFlID)

    strInBook = Mid(strInFl, intPos)

　　'★今回の条件追加のために、IF文を追加
    If strInBook <> ctrlNum Then

        '
        '
        Workbooks(strOutBook).Worksheets(strActiveSheet).Cells(lngRowOut, 2).Value = wbIn.Worksheets(strInSheet).Cells(10, 33).Value
        Workbooks(strOutBook).Worksheets(strActiveSheet).Cells(lngRowOut, 3).Value = wbIn.Worksheets(strInSheet).Cells(10, 34).Value
        '
        '※質問の文字数の都合上略します
        '(略)
        Workbooks(strOutBook).Worksheets(strActiveSheet).Cells(lngRowOut, 69).Value = wbIn.Worksheets(strInSheet).Cells(2, 46).Value

        'ファイルを保存せずに閉じる
        wbIn.Close SaveChanges:=False
        SHEET_PROC = 0
    End If

Exit Function

End Function


Sub set_num()

    Dim WBook As String
    Dim ASheet As String
    Dim L As Integer
    Dim n As Integer

    'ソート
    Rows("11:3000").Select
    Selection.Sort Key1:=Range("D12"), Order1:=xlAscending, _
                   Key2:=Range("E12"), Order2:=xlAscending, Header:=xlYes, _
                   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin

    'Rif番号付け
    L = 12
    n = 1

    WBook = ActiveWorkbook.Name
    ASheet = ActiveSheet.Name

    While Workbooks(WBook).Worksheets(ASheet).Cells(L, 4).Value <> ""
        Workbooks(WBook).Worksheets(ASheet).Cells(L, 1).Value = n
        L = L + 1
        n = n + 1
    Wend

End Sub

### 試したこと
Gotoステートメントの利用など試したのですが、いずれも想定通りの結果にはなりませんでした。


### 補足情報（FW/ツールのバージョンなど）
Excel2016

Comments

[end-u]

'シートの非表示行を表示する
Cells.Select
Selection.EntireColumn.Hidden = False

これはCells.EntireColumn.Hidden = FalseというようにSelectしないでも書けるし
Columns.Hidden = Falseと書ける
何より、
Cells.Select..とか
Range("AQ12:AQ3000")..とか、Rangeの親が何なのか指定していないので、
コード実行時にActiveだったSheetの処理になっていますから危ういです

Dim wb As Workbook
Set wb = ActiveWorkbook 'とかコードがある ThisWorkbookとか
Dim ws As Worksheet
Set ws = wb.Sheets("xxx")
などオブジェクト変数をうまく使って
ws.Cells...
ws.Range("AQ12:AQ3000")...
Active状況依存しないコードにしたほうが良いです

[end-u]

まず確認箇所がQ1～Q3まで

'対応完了日（AQ列）が空白の行の管理NOを取得する
'対応完了日（AQ列）が空白でない行の管理NOを取得する
For Each cell In Range("AQ12:AQ3000")
　　If cell = "" Then
　　　　ny_ctrlNum = cell.Offset(0, -39)
　　ElseIf cell <> "" Then
　　　　ctrlNum = cell.Offset(0, -39)
　　End If
Next

Q1)
Range("AQ12:AQ3000")は必ず固定範囲ですか？
それとも入力済み範囲に限定したいけど変動範囲の指定の仕方がわからなかったのでしょうか？
ex)ws.Range("AQ12", ws.Cells(ws.Rows.Count, "AQ").End(xlUp))

Q2)
"AQ12:AQ3000"までLoopしてますが
変数　ny_ctrlNum　と　ctrlNum　がLoopの度に上書きされますから、
最後の１つずつしか取得しませんが、そのような仕様で良いですか？

'対応完了日（AQ列）が空白の行の値をクリアする
For Each cell In Range("AQ12:AQ3000")
　　If cell = "" Then
　　　　row = Range("AQ12").row
　　　　Rows(row).ClearContents
　　End If
Next

Q3)
これも"AQ12:AQ3000"までLoopしてますが
cell = "" の条件を満たしたとしても、
row = Range("AQ12").row '★
Rows(row).ClearContents

AQ12セル固定してますから12行目が毎回ClearContentsされてしまいます
ひょっとして、２行まとめて
cell.EntireRow.ClearContents
で良かったりしますか？
それに上のLoopと同じ範囲なので、まとめて処理できそうですよね

[end-u]

'ファイルのパスを取得する'
strMyBook = ActiveWorkbook.Name
strActiveSheet = ActiveSheet.Name
この箇所などは、Book名、Sheet名を文字列で取得して
Workbooks(strOutBook).Worksheets(strActiveSheet)など、その文字列で再指定してますが
さっき指摘したように、
Dim ws As Worksheet
Set ws = ActiveSheet
とWorksheetオブジェクト変数に入れてしまい、
Function SHEET_PROC(strInFl As String, strOutBook As String, lngRowOut As Long) As Integer
これも
intRet = SHEET_PROC(file.Path, ws, lngOutRow)
Function SHEET_PROC(strInFl As String, outSht As Worksheet, lngRowOut As Long) As Integer
などとして、Worksheet型でそのまま渡せば
outSht.Cells(lngRowOut, 2).Value = wbIn.Worksheets(strInSheet).Cells(10, 33).Value
outSht.Cells(lngRowOut, 3).Value = wbIn.Worksheets(strInSheet).Cells(10, 34).Value
とできます

[Y.H.]

> 条件を追加したところ、条件を反映されておらず
質問記載のソースコードのどこが「条件を追加した」部分なのかわかるように質問を編集し追記ください。

[momo2134]

@end_uさん
ご指摘いただきありがとうございます。
1番目と3番目のご指摘に関しては、ソースに反映しますので、
可能であれば最終的にソースをご確認いただきたいと思います。

2番目のご指摘・ご質問に関して、以下ご返信致します。

> まず確認箇所がQ1～Q3まで

> '対応完了日（AQ列）が空白の行の管理NOを取得する
> '対応完了日（AQ列）が空白でない行の管理NOを取得する
> For Each cell In Range("AQ12:AQ3000")
> 　　If cell = "" Then
> 　　　　ny_ctrlNum = cell.Offset(0, -39)
> 　　ElseIf cell <> "" Then
> 　　　　ctrlNum = cell.Offset(0, -39)
> 　　End If
> Next

Q1)
> Range("AQ12:AQ3000")は必ず固定範囲ですか？
> それとも入力済み範囲に限定したいけど変動範囲の指定の仕方がわからなかったのでしょうか？
> ex)ws.Range("AQ12", ws.Cells(ws.Rows.Count, "AQ").End(xlUp))

→ご指摘の通り、入力済み範囲に限定したかったのですが、指定の仕方がわからず、一旦3000行までとしていました。最終的にソースにご指摘を反映致します。

Q2)
> "AQ12:AQ3000"までLoopしてますが
> 変数　ny_ctrlNum　と　ctrlNum　がLoopの度に上書きされますから、
> 最後の１つずつしか取得しませんが、そのような仕様で良いですか？

→条件を満たす場合、ny_ctrlNum　と　ctrlNum　は毎回取得したいです。
あわせてQ3に修正案を記載します。ご確認をお願いします。

Q3)
> '対応完了日（AQ列）が空白の行の値をクリアする
> For Each cell In Range("AQ12:AQ3000")
> 　　If cell = "" Then
> 　　　　row = Range("AQ12").row
> 　　　　Rows(row).ClearContents
> 　　End If
> Next

> これも"AQ12:AQ3000"までLoopしてますが
> cell = "" の条件を満たしたとしても、
> row = Range("AQ12").row '★
> Rows(row).ClearContents

> AQ12セル固定してますから12行目が毎回ClearContentsされてしまいます
> ひょっとして、２行まとめて
> cell.EntireRow.ClearContents
> で良かったりしますか？
> それに上のLoopと同じ範囲なので、まとめて処理できそうですよね

→以下修正案です。まだ実行していないため、不備がありましたら申し訳ございません。

Dim wb As Workbook
Dim i As Long
Set wb = ActiveWorkbook

'対策完了日（AQ列）が空白の行の管理NOを取得する
'対策完了日（AQ列）が空白でない行の管理NOを取得する
'対策完了日（AQ列）が空白の行の値をクリアする

For i = Cells(Rows.Count, 41).End(xlUp).Row To 12 Step -1
　If Cells(i, 41).Value = "" Then
　　　ny_ctrlNum = cell.Offset(i, -39)
　　　cells(i, 41).EntireRow.ClearContents
　ElseIf Cells(i, 41).Value <> "" Then
　　　ctrlNum = cell.Offset(i, -39)
　End If
Next

[momo2134]

@Y.H.さん
ご指摘をいただき、今回条件を追加した箇所に"★"で内容を記載しました。
ソース内でわかりづらいですが、ご了承ください。
（上の方にいただいたご指摘などはまだ反映しておらず、質問時のソースのままとしています）
宜しくお願い致します。

[end-u]

> →条件を満たす場合、ny_ctrlNum　と　ctrlNum　は毎回取得したいです。
..という事であれば、

> For i = Cells(Rows.Count, 41).End(xlUp).Row To 12 Step -1
> 　If Cells(i, 41).Value = "" Then
> 　　　ny_ctrlNum = cell.Offset(i, -39)
> 　　　cells(i, 41).EntireRow.ClearContents
　　　　☆ここで対策完了日（AQ列）が空白の行の管理NOを取得　してその後の処理をする
　　　　...いわゆる『更新』でしょうか
　　　　上書きするなら.EntireRow.ClearContentsは必要ないのでは。
> 　ElseIf Cells(i, 41).Value <> "" Then
> 　　　ctrlNum = cell.Offset(i, -39)
　　　　☆対策完了日（AQ列）が空白でない行の管理NOを取得　してその後の処理をする
> 　End If
> Next

..という処理にするか、
ny_ctrlNum　と　ctrlNum　を配列変数にして、
セル範囲Loop後、その変数をLoopしてまとめて処理するか、になりそうです

ですがそもそも
> 問い合わせファイルが増え、マクロの実行に時間がかかるようになったため、
という点が仕様改訂の理由なら、現状コードをブラッシュアップさせて速度改善を図った方が良い気がします？
最大3,000ファイルでしょうか？
実のところ3フォルダ合わせてどれくらいの量で、どれくらいの時間がかかっているのでしょう
SHEET_PROCは１セルずつ書き込みにいってる為、それは時間かかっちゃいますね
配列に取り込んで書き出しは１回で済ますとか
ファイル閉じたまま数式で参照して値化させるとか
改善の方法はありそうです

[momo2134]

@end-uさん
>> →条件を満たす場合、ny_ctrlNum　と　ctrlNum　は毎回取得したいです。
>..という事であれば、

→ソースを再度見直した結果、ny_ctrlNumは取得不要でした。
試行錯誤していた際の不要な変数です。申し訳ございません。

>> For i = Cells(Rows.Count, 41).End(xlUp).Row To 12 Step -1
>> 　If Cells(i, 41).Value = "" Then
>> 　　　ny_ctrlNum = cell.Offset(i, -39)
>> 　　　cells(i, 41).EntireRow.ClearContents
>　　　　☆ここで対策完了日（AQ列）が空白の行の管理NOを取得　してその後の処理をする
>　　　　...いわゆる『更新』でしょうか
>　　　　上書きするなら.EntireRow.ClearContentsは必要ないのでは。
>> 　ElseIf Cells(i, 41).Value <> "" Then
>> 　　　ctrlNum = cell.Offset(i, -39)
>　　　　☆対策完了日（AQ列）が空白でない行の管理NOを取得　してその後の処理をする
>> 　End If
>> Next

→処理として、「対応完了日（AQ列）が空白の行（旧レコード）の管理NOを取得し、
その管理NOと一致する問い合わせファイルのみを一覧に追加（新レコード）する」ことをイメージしていたため、
旧レコードのクリアが必要という認識でした。（上書きする仕方がわからなかったという理由もありますが、、、）

> ..という処理にするか、
> ny_ctrlNum　と　ctrlNum　を配列変数にして、

→ctrlNumを配列変数にする場合、データ数は「ファイル数」という考え方でよろしいでしょうか？

> セル範囲Loop後、その変数をLoopしてまとめて処理するか、になりそうです

> ですがそもそも
>> 問い合わせファイルが増え、マクロの実行に時間がかかるようになったため、
> という点が仕様改訂の理由なら、現状コードをブラッシュアップさせて速度改善を図った方が良い気がします？
> 最大3,000ファイルでしょうか？
> 実のところ3フォルダ合わせてどれくらいの量で、どれくらいの時間がかかっているのでしょう

→現状ファイル数は600ほどで、処理に1時間～1.5時間かかっています。
　これほど時間がかかるのは、他の要因もあるかもしれません。。。

> SHEET_PROCは１セルずつ書き込みにいってる為、それは時間かかっちゃいますね
> 配列に取り込んで書き出しは１回で済ますとか
> ファイル閉じたまま数式で参照して値化させるとか
> 改善の方法はありそうです

→ネットにも配列にした方が早いという情報があり、検討したのですが、
問い合わせファイル内は、セルが結合されていたりと転記元のセルに規則性がなく、実現方法がわからず、
転記するファイルを絞ることで処理時間を早くしようと考えました。

可能であれば、処理時間は早ければ早い方がよく、
配列に取り込む　+　書き込むファイル数も絞る　ができればよいと考えているのですが、
可能なものでしょうか？

何度もご返信いただきありがとうございます。

Answer 1

          [A]	[B]	   [C]  	[D]
[1]	問い合わせ一覧表			
[2]				
[3]	件名	対応日時	対応状況	内容
[4]				
[5]				

こんな表がマクロブックの一番左のシートに作ってあるとして、
以下のようなことがしたいのでは？

Option Explicit

Dim mFSO As FileSystemObject

Sub 一覧表更新()
    Dim rngList As Range
    Dim vrtSubjectList As Variant

    'FileSystemObjectを呼び出す(実体化)
    Set mFSO = New FileSystemObject

    '一覧表のセル範囲取得
    Set rngList = ThisWorkbook.Worksheets(1).Range("A3").CurrentRegion

    '空欄クリア
    InitializeTable rngList

    '一覧にないファイルのリストを取得
    vrtSubjectList = Get_UpdatedSubjectList(rngList)

    'データの転記
    SetUpdated vrtSubjectList, rngList
End Sub

'表中の対応日時が空欄の行をクリア
Private Sub InitializeTable(ByRef rngList As Range)
    Dim rngBlank As Range

    With rngList
        If rngList.Rows.Count > 1 Then
            On Error Resume Next
            Set rngBlank = rngList.Columns(2).SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            If rngBlank Is Nothing Then Exit Sub

            rngBlank.EntireRow.ClearContents
            rngList.Sort Key1:=rngList(2), Order1:=xlAscending, Header:=xlYes
        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 strBaseName As String
    Dim vrtOld As Variant
    Dim vrtNewList() As Variant
    Dim ix As Long
    
    ReDim vrtNewList(1 To 50000)
    Set WSF = Application.WorksheetFunction
    '入力済みの件名リスト
    vrtOld = WSF.Transpose(rngList.Columns(1))

    strPath = ThisWorkbook.Path

    For Each myFolder In mFSO.GetFolder(strPath).SubFolders
        For Each myFile In myFolder.Files
            strBaseName = mFSO.GetBaseName(myFile.Path)
            If IsError(Application.Match(strBaseName, vrtOld, 0)) Then
                ix = ix + 1
                vrtNewList(ix) = myFile.Path
            End If
        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 c As Range
    Dim f As Variant
    Dim strContent As String
    Dim ix As Long
    Dim vrtNewList() As Variant
    ReDim vrtNewList(LBound(vrtSubjectList) To UBound(vrtSubjectList), 1 To 4)

    For Each f In vrtSubjectList
        ix = ix + 1
        With Workbooks.Open(f, 0)
            strContent = .Worksheets(1).Range("C5").Value
            .Close False
        End With

        With mFSO
            vrtNewList(ix, 1) = .GetBaseName(f)
            vrtNewList(ix, 3) = .GetFile(f).ParentFolder.Name
        End With
        vrtNewList(ix, 4) = strContent
    Next

    With rngList
        Set rngList = .Cells(.Rows.Count + 1, 1).Resize(UBound(vrtNewList, 1), UBound(vrtNewList, 2))
    End With
    rngList.Value = vrtNewList

    ix = 0
    For Each c In rngList.Columns(1).Cells
        ix = ix + 1
        rngList.Worksheet.Hyperlinks.Add _
                Anchor:=c, _
                Address:=vrtSubjectList(ix), _
                ScreenTip:="クリックでリンクを開きます。", _
                TextToDisplay:=c.Value
    Next
End Sub

Comments

[momo2134]

@mattuwanさん

遅くなり申し訳ございません。ご回答いただきありがとうございます。
まさに私がやりたかったことを、ご記載いただきありがとうございます。

いただいたソースコードを拝見し、調べながらも理解しようとしているのですが、
（mattuwanさんにいただいたサンプルコードを元に、マクロを作成しようとしております）
私の知識不足もあり、"データの転記"のプロシージャ内の処理が理解できずにいます。
処理の概要を簡単にご説明いただくことは可能でしょうか？宜しくお願い致します。

[mattuwan]

え？

1）渡されたリストをリストが無くなるまで繰り返し順次見て行く
2）指定のセルの値を変数に記録
3）ファイルの拡張子抜きの名前を変数に記録
4）親フォルダーのパスを変数に記録
5）1へ戻る
6）変数に入れたものを、セルに転記
7）転記したセルの1列目にハイパーリンクを順次設定

というような内容です。
ステップインで実行しながら、ローカルウィンドウで変数の中身を確認してみたください。
参考URL>>
http://www.ken3.org/vba/excel-help.html

ええと、
セルを一個づつ大量に読み書きするとすごく時間がかかります。
（1つのセルに書きこむのに0.01秒かかったとしても、
10000個のセルに書きこむと100秒かかりますよね？）
なので、結果を一旦変数に溜めておき、
最後に1回でセルに転記しています。
参考URL>>
http://officetanaka.net/excel/vba/speed/s11.htm
https://vbabeginner.net/vba%E3%81%A7%E4%BA%8C%E6%AC%A1%E5%85%83%E9%85%8D%E5%88%97%E3%81%AE%E3%83%87%E3%83%BC%E3%82%BF%E3%82%92%E9%AB%98%E9%80%9F%E3%81%AB%E3%82%BB%E3%83%AB%E3%81%B8%E8%B2%BC%E3%82%8A%E4%BB%98%E3%81%91/

なんかいいサイトが簡単にみつからないな＾＾；
根気強く探してみてください。
求める情報を探せるようになると、回答を待つ時間がなくなるので、
開発がスムーズに進むと思います。

Answer 2

うーん...簡易的に30KBのxlsxファイル×1,110個でテストしてみて250secほど。
（旧環境Core i7/3.10GHz、メモリ4GB、Win7pro32bit、Excel2010で）
やっぱり厳しいなぁ

Sub test1()
    Dim Fold As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Fold = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Const cx = 100 '列数
    Dim fso      As Object 'FileSystemObject
    Dim f        As Object 'file
    Dim ws       As Worksheet
    Dim wrk      As Worksheet
    Dim i        As Long
    Dim cnt      As Long
    Dim tgFol(2) As String
    Dim ret(1 To 3000, 1 To cx)

    Dim t As Single: t = Timer
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    tgFol(0) = Fold & "\10 未対応"
    tgFol(1) = Fold & "\20 対応中"
    tgFol(2) = Fold & "\30 対応済み"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim j As Long
    For i = 0 To 2
        For Each f In fso.GetFolder(tgFol(i)).Files
            If f.Name Like "*お客様問い合わせファイル*" Then
                cnt = cnt + 1
                With Workbooks.Open(f.Path, UpdateLinks:=False, ReadOnly:=True)
                    On Error Resume Next
                    Set ws = .Sheets("問い合わせ")
                    On Error GoTo 0
                    ret(cnt, 1) = f.Path
                    If Not ws Is Nothing Then
                        ret(cnt, 2) = ws.Range("B2").Value
                        ret(cnt, 3) = ws.Range("B3").Value
                        ret(cnt, 4) = ws.Range("B4").Value
                        ret(cnt, 5) = ws.Range("B5").Value
                        ret(cnt, 6) = ws.Range("B6").Value
                        ret(cnt, 7) = ws.Range("B7").Value
                        ret(cnt, 8) = ws.Range("B8").Value
                        ret(cnt, 9) = ws.Range("B9").Value
                        ':ダミーなのでテスト的にセット（並びが規則的ならLoopできる）
                        With ws.Range("C1:E50")
                            For j = 10 To 99
                                ret(cnt, j) = .Item(j).Value
                            Next
                        End With
                        ret(cnt, 100) = ws.Range("F10").Value
                    End If
                    .Close False
                End With
            End If
        Next f
    Next
    'とりあえず新規Sheetに書き出し
    ThisWorkbook.Sheets.Add.Range("A2").Resize(cnt, cx).Value = ret

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Debug.Print cnt, Timer - t
End Sub

可能であれば、処理時間は早ければ早い方がよく、
配列に取り込む　+　書き込むファイル数も絞る　ができればよいと考えているのですが、

この方針がいいですよねぇ...
ステータス毎にフォルダを移動したとしても、元のファイル名がユニークなら、
最初に一覧表に書き込む時にファイル名も記録しておくようにしませんか
そうすると、「更新」であれ「新規登録」であれ、そのファイル名でピンポイントに開いて処理すれば良いと思うんですよね
直前に子フォルダ含めたファイルリストをまず作って、それを参照すれば良いと思いますし。

---

（追記）
＞ 問い合わせ毎のファイルはユニークなファイル名なので、
..という事であれば
＞ 直前に子フォルダ含めたファイルリストをまず作って、それを参照すれば良いと思いますし。
のサンプル

Sub sample()
    Dim Fold As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Fold = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Dim tgFol(2) As String
    
    tgFol(0) = Fold & "\10 未対応"
    tgFol(1) = Fold & "\20 対応中"
    tgFol(2) = Fold & "\30 対応済み"

    Dim fso As Object 'Scripting.FileSystemObject
    Dim f   As Object 'file
    Dim dic As Object 'Scripting.dictionary
    Dim i   As Long
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dic = CreateObject("Scripting.Dictionary")
    '３フォルダ全ファイルからユニークファイル名をkeyにして _
     ファイルフルパスをdictionaryに登録する
    For i = 0 To 2
        For Each f In fso.GetFolder(tgFol(i)).Files
            If f.Name Like "*お客様問い合わせファイル*" Then
                dic(f.Name) = f.Path
            End If
        Next
    Next
    '↑ここまでは少し時間かかる

    Dim key As String
    Dim rng As Range
    Dim r   As Range
    Dim ret(1 To 69)

    With ActiveSheet 'とかThisWorkbook.Sheets("data")とか
        Set rng = .Range("AQ12", .Cells(.Rows.Count, "AQ").End(xlUp))
    End With

    For Each r In rng
        If r.Value = "" Then
            'ユニークファイル名がr.RowのA列にある場合
            key = r.EntireRow.Range("A1").Value
            '例えば別シートのrと同じ行にあるなら
            'key = ThisWorkbook.Sheets("一覧").Cells(r.Row, "A").Value
            
            'dic(key)でフルパスを取り出す
            With Workbooks.Open(dic(key), UpdateLinks:=False, ReadOnly:=True)
                With .Sheets("問い合わせ")
                    '1×69の配列にデータセット
                    ret(1) = .Range("AG10").Value
                    ret(2) = .Range("AH10").Value
                    ':
                    ':
                    ':
                    ret(69) = .Range("AT2").Value
                End With
                .Close False
            End With
            'Value = ""条件の rの行のB列から右に69セル拡張した範囲に書き込み
            r.EntireRow.Range("B1").Resize(, 69).Value = ret
        Else
            ':
            ':
        End If
    Next

End Sub

---

（2020.04.04追加）
新規登録を追加
「dic.keys()にあって、ファイルリストにないもの」を追加すればいいので、
Match関数でまとめて配列CheckしてLoop時エラー値のものを処理します
処理内容は更新と同じなのでサブプロシージャにして外出し。

'---------------------------------------------------------------------
Sub sample2()
    Dim Fold As String
    Fold = ThisWorkbook.Path 'とかActiveWorkbook.Pathとか

    Dim tgFol(2) As String
    
    tgFol(0) = Fold & "\10 未対応"
    tgFol(1) = Fold & "\20 対応中"
    tgFol(2) = Fold & "\30 対応済み"

    Dim fso As Object 'Scripting.FileSystemObject
    Dim f   As Object 'file
    Dim dic As Object 'Scripting.dictionary
    Dim i   As Long
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dic = CreateObject("Scripting.Dictionary")
    '３フォルダ全ファイルからユニークファイル名をkeyにして _
     ファイルフルパスをdictionaryに登録する
    For i = 0 To 2
        For Each f In fso.GetFolder(tgFol(i)).Files
            If f.Name Like "*お客様問い合わせファイル*" Then
                dic(f.Name) = f.Path
            End If
        Next
    Next
    '↑ここまでは少し時間かかる

    Dim key As String
    Dim rng As Range
    Dim r   As Range

    With ActiveSheet 'とかThisWorkbook.Sheets("data")とか
        Set rng = .Range("AQ12", .Cells(.Rows.Count, "AQ").End(xlUp))
    End With

    For Each r In rng
        If r.Value = "" Then
            'ユニークファイル名がr.RowのA列にある場合
            key = r.EntireRow.Range("A1").Value
            '例えば別シートのrと同じ行にあるなら
            'key = ThisWorkbook.Sheets("一覧").Cells(r.Row, "A").Value
            
            'dic(key)でフルパスを取り出してサブプロシージャへ
            Call wkGetdata(dic(key), r)
        Else
            ':
            ':
        End If
    Next
    
    '新規登録チェック
    Dim chk, buf
    chk = Application.Match(dic.keys(), rng.EntireRow.Columns(1), 0)
    '新規書き出し位置
    Set r = rng.Offset(rng.Count).Item(1)
    For i = 1 To UBound(chk)
        If IsError(chk(i)) Then
            key = dic(dic.keys()(i))
            'フォルダによって除外するなら条件分岐させる
            'buf = Split(key, "\")
            'If buf(5) <> "30 対応済み" Then
                Call wkGetdata(key, r)
                'ファイル名も忘れずに追加
                r.EntireRow.Range("A1").Value = dic.keys()(i)
                Set r = r.Offset(1)
            'End If
        End If
    Next

End Sub
'---------------------------------------------------------------------
Sub wkGetdata(fName As String, r As Range)
    Dim ret(1 To 69)
    With Workbooks.Open(fName, UpdateLinks:=False, ReadOnly:=True)
        With .Sheets("問い合わせ")
            '1×69の配列にデータセット
            ret(1) = .Range("AG10").Value
            ret(2) = .Range("AH10").Value
            ':
            ':
            ':
            ret(69) = .Range("AT2").Value
        End With
        .Close False
    End With
    'Value = ""条件の rの行のB列から右に69セル拡張した範囲に書き込み
    r.EntireRow.Range("B1").Resize(, 69).Value = ret
End Sub
'---------------------------------------------------------------------

変数を使い回ししてるので解り難ければ適宜変更してください

Comments

[momo2134]

@end-uさん

サンプルソースを作成いただきありがとうございます。
問い合わせ毎のファイルはユニークなファイル名なので、
一覧の別シートに取り込むファイル名の一覧を記録する方式でも問題ないです。

いただいたサンプルソースを拝見して、
ファイル間の転記方法がすっきりしていてかなり参考になりました。
ありがとうございます。

[momo2134]

@end-uさん
サンプルを追記いただきありがとうございます。
確認させてただき、以下いくつかご質問させていただきたいことがあります。
処理の概要として下記のように理解しました。

1：一覧ファイル・子フォルダが格納されているフォルダを選択させる
2：3つの子フォルダ内全ファイルのフルパスをdictionaryシートに登録
3：一覧シートのAQ列がnullの場合、その行のA列をキーに、dictionaryシートのフルパスから対象ファイルを開く
4：ファイルのデータを配列に格納
5：配列に格納したデータを一覧の対象の行にB1から順にデータを書き込む
6：3～5を一覧のレコード件数分繰り返す

【質問】
Q1）
1のフォルダを選択する作業をなくし、マクロを実行するとdictionaryシートに自動で2の処理を行なうことは可能でしょうか？
Q2）
一覧上にはないが、子フォルダ内には新しく書き込みたいファイルがある場合（問い合わせファイルは日々増えるため）
3での条件を増やすことで実現可能でしょうか？

マクロの修正が必要になってからVBAの勉強を始めていますが、知識が追いついていない部分もあり、
ご質問ばかりになってしまい、申し訳ございません。
宜しくお願い致します。

[end-u]

処理概要はその通りです
(Q1)(Q2)とも、「可能ですか？」と問われると yes です
それで終わってもなんなのでサンプル追加しました

ステップ実行とか
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html
ローカルウィンドウとか
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_040_03.html
使って参考にしてみてください