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

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

ただいまの
回答率

89.12%

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

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 368

momo2134

score 5

前提・実現したいこと

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

  • 気になる質問をクリップする

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

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

  • momo2134

    2020/04/02 10:29

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

    キャンセル

  • end-u

    2020/04/02 11:09

    > →条件を満たす場合、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は1セルずつ書き込みにいってる為、それは時間かかっちゃいますね
    配列に取り込んで書き出しは1回で済ますとか
    ファイル閉じたまま数式で参照して値化させるとか
    改善の方法はありそうです

    キャンセル

  • momo2134

    2020/04/02 12:11 編集

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

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

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

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

    キャンセル

回答 2

checkベストアンサー

+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

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2020/04/22 19:29 編集

    @mattuwanさん

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

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

    キャンセル

  • 2020/04/22 20:33

    え?

    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/

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

    キャンセル

+1

うーん...簡易的に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")
    '3フォルダ全ファイルからユニークファイル名を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")
    '3フォルダ全ファイルからユニークファイル名を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
'---------------------------------------------------------------------


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

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2020/04/03 15:25

    @end-uさん

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

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

    キャンセル

  • 2020/04/04 18:31 編集

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

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

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

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

    キャンセル

  • 2020/04/04 20:09

    処理概要はその通りです
    (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
    使って参考にしてみてください

    キャンセル

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

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