回答編集履歴

追加

2020/04/04 11:02

投稿

end-u

スコア52

test CHANGED Viewed

@@ -339,3 +339,203 @@
 End Sub
 ```
+---
+（2020.04.04追加）
+新規登録を追加
+「dic.keys()にあって、ファイルリストにないもの」を追加すればいいので、
+Match関数でまとめて配列CheckしてLoop時エラー値のものを処理します
+処理内容は更新と同じなのでサブプロシージャにして外出し。
+```VBA
+'---------------------------------------------------------------------
+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
+'---------------------------------------------------------------------
+```
+変数を使い回ししてるので解り難ければ適宜変更してください

誤字修正

2020/04/04 11:01

投稿

end-u

スコア52

test CHANGED Viewed

@@ -274,7 +274,7 @@
     With ActiveSheet 'とかThisWorkbook.Sheets("data")とか
-        Set rng = .Range("AR12", .Cells(.Rows.Count, "AR").End(xlUp))
+        Set rng = .Range("AQ12", .Cells(.Rows.Count, "AQ").End(xlUp))
     End With

サンプル追加です

2020/04/03 15:22

投稿

end-u

スコア52

test CHANGED Viewed

@@ -175,3 +175,167 @@
 そうすると、「更新」であれ「新規登録」であれ、そのファイル名でピンポイントに開いて処理すれば良いと思うんですよね
 直前に子フォルダ含めたファイルリストをまず作って、それを参照すれば良いと思いますし。
+---
+（追記）
+＞ 問い合わせ毎のファイルはユニークなファイル名なので、
+..という事であれば
+＞ 直前に子フォルダ含めたファイルリストをまず作って、それを参照すれば良いと思いますし。
+のサンプル
+```VBA
+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("AR12", .Cells(.Rows.Count, "AR").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
+```