編集履歴

回答編集履歴

追記

2016/06/15 07:43

投稿

スコア3013

test CHANGED Viewed

@@ -210,43 +210,203 @@
 以下に対象となっているシートと、セルの値を表示するサンプルを作成してみました。
+　⇒　長くなりすぎたので全体ソースを参照してください。
+これで状況を確認してみてください。
+全体ソース
+---
-```
+```
+Option Explicit
+Dim gyo As Long
+Dim gyo2 As Long
+Dim filecount As Long
+Dim sheetcount As Long
+Dim unmatch As Long
+Dim erfilecount As Long
+'ボタンを押したとき
+Sub FolderSelect()
+    ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
+    ThisWorkbook.Worksheets(2).Range("A3:AS3005").ClearContents
+    Dim folderpass As String
+    With Application.FileDialog(msoFileDialogFolderPicker)
+        If .Show = True Then
+            folderpass = .SelectedItems(1)
+        Else
+            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
+            Exit Sub
+        End If
+    End With
+    filecount = 0
+    sheetcount = 0
+    unmatch = 0
+    erfilecount = 0
+    gyo = 6
+    gyo2 = 3
+    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
+    Call FileSearch(folderpass, "*.xls*")
+    Dim dateupdate As String
+    dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
+    ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
+    ThisWorkbook.Worksheets(2).Name = dateupdate
+    ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
+    ThisWorkbook.Worksheets(2).Activate
+End Sub
+'ファイル検索
+Sub FileSearch(Path As String, Target As String)
+    Dim FSO As Object, Folder As Variant, File As Variant
+    Set FSO = CreateObject("Scripting.FileSystemObject")
+    Dim wsStatusSheet As Worksheet  '状況出力シート
+    Set wsStatusSheet = ThisWorkbook.Worksheets(1)
+    '全てのサブフォルダをループ処理
+    For Each Folder In FSO.GetFolder(Path).SubFolders
+        'サブフォルダを指定して再帰呼び出し
+        Call FileSearch(Folder.Path, Target)
+    Next Folder
+    'フォルダ内のすべてのファイルをループ処理
+    For Each File In FSO.GetFolder(Path).Files
+        If File.Name Like Target Then
+            'ファイル名がTargetに含まれる場合、処理対象
+            filecount = filecount + 1
+            wsStatusSheet.Cells(gyo, 1) = File.Name    'ファイル名を出力
+            wsStatusSheet.Cells(gyo, 2) = File.Path    'ファイルパスを出力
+            'コピー処理
+            Call ParCopy(File.Path)
+            gyo = gyo + 1
+        End If
+        wsStatusSheet.Range("B3").Value = filecount & "個のファイルが見つかりました。"
+    Next File
+End Sub
+''一覧出力
 Sub ParCopy(Path As String)
     'Dim i As Long
     'Dim j As Long
     Dim openbook As Workbook
     Dim openbooksheet As Worksheet
     Application.ScreenUpdating = False
     On Error GoTo myError
     Set openbook = Application.Workbooks.Open(Path)
     '一覧化コピペ
     'For i = 1 To openbook.Worksheets.Count
         Set openbooksheet = openbook.Worksheets(1)
         'Dim blof As Variant
@@ -258,13 +418,13 @@
         'Next j
         Dim strMsg As String    'デバッグ用メッセージ
         strMsg = ""
         If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> 1 Then
@@ -294,7 +454,7 @@
                     ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
                     'デバッグ用メッセージに書き出し
@@ -322,27 +482,27 @@
                     strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
                     gyo2 = gyo2 + 1
         End If
         '処理中のファイル名・シート名を画面表示する
-        Msgbox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
+        MsgBox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
     'Next i
     openbook.Close False
     Application.ScreenUpdating = True
@@ -362,6 +522,6 @@
-これで状況を確認してみてください。
+このコードで、指定フォルダ配下の２ファイル、およびそのサブフォルダ配下の１ファイルからの情報取得を確認しています。

追記

2016/06/15 07:43

投稿

jawa

スコア3013

test CHANGED Viewed

@@ -14,6 +14,12 @@
+気になったこと
+---
 ソース上、気になる点がいくつかありました。
 ①全シート数分のループ処理をしているのに、読み込みシートは常にシート１でよいのか？
@@ -160,6 +166,10 @@
 ---
 追記を受けて
 ---

追記

2016/06/14 07:53

投稿

jawa

スコア3013

test CHANGED Viewed

@@ -155,3 +155,203 @@
  ⇒具体的に空セルがセットされるメカニズムを把握する
 といった調査で原因を特定していけばよいと思います。
+---
+追記を受けて
+---
+やりたいことはおおよそ伝わりましたが、エラーの発生状況がまだよくわかりません。
+コードが期待通りのロジックとなっているのなら、取り込まれる側シートのA70,R2,…AE48の内容を取り込む側シートの6,7,42,…56列目にコピーしたいのだと思います。
+・これらすべてが空欄となるのか
+・あるファイルの分はコピーできているが、あるファイルの分は空欄となってしまうのか
+追加で気になったこと
+---
+コード内で読み取るシートを
+```
+Set openbooksheet = openbook.Worksheets(1)
+```
+と指定しています。
+これで取得できるシートは、ブック内で一番左側のシートです。
+これには非表示のシートも含まれますので、一番左のシートが非表示の場合、見えていないシートからデータを取得することになります。
+以下に対象となっているシートと、セルの値を表示するサンプルを作成してみました。
+```
+Sub ParCopy(Path As String)
+    'Dim i As Long
+    'Dim j As Long
+    Dim openbook As Workbook
+    Dim openbooksheet As Worksheet
+    Application.ScreenUpdating = False
+    On Error GoTo myError
+    Set openbook = Application.Workbooks.Open(Path)
+    '一覧化コピペ
+    'For i = 1 To openbook.Worksheets.Count
+        Set openbooksheet = openbook.Worksheets(1)
+        'Dim blof As Variant
+        'ReDim blofar(0 To 1)
+        'For j = 0 To UBound(blof)
+        '    blofar(j) = Trim(blof(j))
+        'Next j
+        Dim strMsg As String    'デバッグ用メッセージ
+        strMsg = ""
+        If openbooksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row <> 1 Then
+                    'シートに書き出し
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 6) = openbooksheet.Range("A70")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 7) = openbooksheet.Range("A70")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 42) = openbooksheet.Range("R2")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 43) = openbooksheet.Range("AC43")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 44) = openbooksheet.Range("AC44")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 45) = openbooksheet.Range("AC45")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 46) = openbooksheet.Range("AC46")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 47) = openbooksheet.Range("AE48")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 49) = openbooksheet.Range("AA2")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 52) = openbooksheet.Range("M22")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 54) = openbooksheet.Range("T22")
+                    ThisWorkbook.Worksheets(2).Cells(gyo2, 56) = openbooksheet.Range("M22")
+                    'デバッグ用メッセージに書き出し
+                    strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
+                    strMsg = strMsg & "A70 :" & openbooksheet.Range("A70") & vbCr
+                    strMsg = strMsg & "R2  :" & openbooksheet.Range("R2") & vbCr
+                    strMsg = strMsg & "AC43:" & openbooksheet.Range("AC43") & vbCr
+                    strMsg = strMsg & "AC44:" & openbooksheet.Range("AC44") & vbCr
+                    strMsg = strMsg & "AC45:" & openbooksheet.Range("AC45") & vbCr
+                    strMsg = strMsg & "AC46:" & openbooksheet.Range("AC46") & vbCr
+                    strMsg = strMsg & "AE48:" & openbooksheet.Range("AE48") & vbCr
+                    strMsg = strMsg & "AA2 :" & openbooksheet.Range("AA2") & vbCr
+                    strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
+                    strMsg = strMsg & "T22 :" & openbooksheet.Range("T22") & vbCr
+                    strMsg = strMsg & "M22 :" & openbooksheet.Range("M22") & vbCr
+                    gyo2 = gyo2 + 1
+        End If
+        '処理中のファイル名・シート名を画面表示する
+        Msgbox "ファイル名：" & Path & vbCr & "シート名：" & openbooksheet.Name & vbCr & strMsg
+    'Next i
+    openbook.Close False
+    Application.ScreenUpdating = True
+    Exit Sub
+myError:
+    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
+    erfilecount = erfilecount + 1
+    Application.ScreenUpdating = True
+End Sub
+```
+これで状況を確認してみてください。

修正

2016/06/14 07:43

投稿

jawa

スコア3013

test CHANGED Viewed

@@ -1,4 +1,4 @@
-どんなデータを読みとった時にどんな動作をしているのか、
+どんなデータを読みとった時にどんな動作をするのか、
 ・期待する動作

修正

2016/06/14 05:59

投稿

jawa

スコア3013

test CHANGED Viewed

@@ -1,10 +1,12 @@
+どんなデータを読みとった時にどんな動作をしているのか、
 ・期待する動作
 ・実際の動作
 ・対象フォルダの構成
-などが不明瞭なので的確なアドバイスができているかわかりませんが。
+が不明瞭なので的確なアドバイスができているかわかりませんが。
@@ -26,7 +28,7 @@
-②配列でない変数を配列として扱っている為エラーが発生している
+②配列でない変数を配列として扱っている為エラーが発生している　⇒不要な処理であれば削除する
 ```