Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1423 / 13646 ツリー ←次へ | 前へ→

【74572】フォルダ(サブフォルダ含)内ブックのデータ集計について じゃっかる 13/7/28(日) 16:18 質問[未読]
【74573】Re:フォルダ(サブフォルダ含)内ブックの... kanabun 13/7/28(日) 18:41 発言[未読]
【74574】Re:フォルダ(サブフォルダ含)内ブックの... じゃっかる 13/7/28(日) 20:31 発言[未読]
【74575】Re:フォルダ(サブフォルダ含)内ブックの... kanabun 13/7/28(日) 21:22 発言[未読]
【74576】Re:フォルダ(サブフォルダ含)内ブックの... kanabun 13/7/28(日) 21:32 発言[未読]
【74577】Re:フォルダ(サブフォルダ含)内ブックの... kanabun 13/7/28(日) 22:43 発言[未読]
【74578】Re:フォルダ(サブフォルダ含)内ブックの... じゃっかる 13/7/29(月) 10:55 質問[未読]
【74579】Re:フォルダ(サブフォルダ含)内ブックの... kanabun 13/7/29(月) 12:17 発言[未読]
【74580】Re:フォルダ(サブフォルダ含)内ブックの... じゃっかる 13/7/29(月) 14:48 お礼[未読]

【74572】フォルダ(サブフォルダ含)内ブックのデ...
質問  じゃっかる  - 13/7/28(日) 16:18 -

引用なし
パスワード
   VBA初心者です。
フォルダ内(サブフォルダ含む)のブックの特定シートの特定セル(複数)を抽出して、別ブックにて集計を行いたいです。
自分なりに調べまして以下のように組んでみましたが、サブフォルダからの抽出ができません。
ご教授願います。

Sub 練習01()

Dim FName As String
Dim FPath As String
Dim cnt As Integer

'画面更新オフ
Application.ScreenUpdating = False
'累積データがある列のデータ下端を取得
cnt = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

FPath = "C:\Documents and Settings\PC名\デスクトップ\練習用データ" \'対象フォルダのパス
ChDir FPath
FName = Dir("*.xls")

Do While FName <> ""
Workbooks.Open FName

ThisWorkbook.Sheets(1).Cells(cnt, 1) = Sheets("1枚目").Range("a1").Value
ThisWorkbook.Sheets(1).Cells(cnt, 2) = Sheets("1枚目").Range("a2").Value

cnt = cnt + 1

ActiveWorkbook.Close
FName = Dir()
Loop

'画面更新オン
Application.ScreenUpdating = True

【74573】Re:フォルダ(サブフォルダ含)内ブック...
発言  kanabun  - 13/7/28(日) 18:41 -

引用なし
パスワード
   ▼じゃっかる さん:

> サブフォルダからの抽出ができません。

他の掲示板に最近レスしたのですけど、
Dir関数でサブフォルダも検索するのは難しい(出来ないという意味ではあ
りません)ので、代わりに、Dirコマンドで サブフォルダも含むファイル名を
配列に取得しておいて、これをループで順に開いて集計すればいいと思います。

ht tp://officetanaka.com/patio/patio.cgi?mode=view&no=3596

【74574】Re:フォルダ(サブフォルダ含)内ブック...
発言  じゃっかる  - 13/7/28(日) 20:31 -

引用なし
パスワード
   kanabun さま

レスありがとうございます。
なんとなくは、言われることがわかるのですが、具体的にどう組み込めばよいかが全く分かりません。
もしよろしければ、コードもかいていただけないでしょうか。
不躾なお願いかとは思いますが、近日中に仕上げなければならない処理があり、またこういったプログラミング的なことが全く初めてでどこをどうしたらよいやら困り果てております。重ねてお願い申し上げます。

【74575】Re:フォルダ(サブフォルダ含)内ブック...
発言  kanabun  - 13/7/28(日) 21:22 -

引用なし
パスワード
   ▼じゃっかる さん:


> なんとなくは、言われることがわかるのですが、
> 具体的にどう組み込めばよいかが全く分かりません。

リンク先のコードは 大まかに言って

(1) 対象フォルダの指定
(2) 指定フォルダ内の(サブフォルダも含めた)ファイルの取得
(3) 検索されたBookに対する処理

のような形をとっています。そこは分かりますよね。

で、まるごとコピペで動かしてみて、 (1) (2) は何ら問題ないと思います。
変更するとすれば
(3)の部分、すなわち

>  'Bookごとの処理
>  Dim book
>  Dim ws As Worksheet
>  
>  For Each book In FoundFiles
>    With Workbooks.Open(book)
>      On Error Resume Next
>      Set ws = .Worksheets("表紙")
>      On Error GoTo 0
>      If ws Is Nothing Then
>        MsgBox "このBookには指定シートがありません"
>      Else
>        ws.Range("E36").Formula = "=SUM('1:31'!M15)"
>        Set ws = Nothing
>      End If
>      .Close True
>    End With
>  Next

の部分かと思います。

ここを、
> Workbooks.Open FName
>
> ThisWorkbook.Sheets(1).Cells(cnt, 1) = Sheets("1枚目").Range("a1").Value
> ThisWorkbook.Sheets(1).Cells(cnt, 2) = Sheets("1枚目").Range("a2").Value
>
> cnt = cnt + 1
>
> ActiveWorkbook.Close

の処理に替えるだけですけど?

【74576】Re:フォルダ(サブフォルダ含)内ブック...
発言  kanabun  - 13/7/28(日) 21:32 -

引用なし
パスワード
   ▼じゃっかる さん:


>リンク先のコードは 大まかに言って
>
>(1) 対象フォルダの指定
>(2) 指定フォルダ内の(サブフォルダも含めた)ファイルの取得
>(3) 検索されたBookに対する処理
>
>のような形をとっています。そこは分かりますよね。
>
>で、まるごとコピペで動かしてみて、 (1) (2) は何ら問題ないと思います。
>変更するとすれば

>(3)の部分、すなわち
>
>>  'Bookごとの処理
>>  Dim book
>>  Dim ws As Worksheet
>>  
>>  For Each book In FoundFiles
>>    With Workbooks.Open(book)
>>      On Error Resume Next
>>      Set ws = .Worksheets("表紙")
>>      On Error GoTo 0
>>      If ws Is Nothing Then
>>        MsgBox "このBookには指定シートがありません"
>>      Else
>>        ws.Range("E36").Formula = "=SUM('1:31'!M15)"
>>        Set ws = Nothing
>>      End If
>>      .Close True
>>    End With
>>  Next
>
>の部分かと思います。
>
>ここを、

  'Bookごとの処理
  Dim cnt As Long: cnt = 1
  Dim book
  Dim ws As Worksheet
  
  For Each book In FoundFiles
    With Workbooks.Open(book)
      On Error Resume Next
      Set ws = .Worksheets("1枚目")
      On Error GoTo 0
      If ws Is Nothing Then
        MsgBox "このBookには指定シートがありません"
      Else
        With ThisWorkbook.Sheets(1)
          .Cells(cnt, 1).Value = ws.Range("A1").Value
          .Cells(cnt, 2).Value = ws.Range("A2").Value
        End With
        Set ws = Nothing
      End If
      .Close True
    End With
  Next

と、こうしたらどうなります?

【74577】Re:フォルダ(サブフォルダ含)内ブック...
発言  kanabun  - 13/7/28(日) 22:43 -

引用なし
パスワード
   ▼じゃっかる さん:

>>ここを、
>
>  'Bookごとの処理
>  Dim cnt As Long: cnt = 1
>  Dim book
>  Dim ws As Worksheet
>  
>  For Each book In FoundFiles
>    With Workbooks.Open(book)
>      On Error Resume Next
>      Set ws = .Worksheets("1枚目")
>      On Error GoTo 0
>      If ws Is Nothing Then
>        MsgBox "このBookには指定シートがありません"
>      Else
>        With ThisWorkbook.Sheets(1)
>          .Cells(cnt, 1).Value = ws.Range("A1").Value
>          .Cells(cnt, 2).Value = ws.Range("A2").Value
>        End With
>        Set ws = Nothing
>      End If
>      .Close True
>    End With
>  Next
>
>と、こうしたらどうなります?

訂正
OpenしたBookを Closeするところ、

>      .Close True

は、 変更を保存する設定になってますが、今回はそんな必要ないので

      .Close False

でよかったですね。

【74578】Re:フォルダ(サブフォルダ含)内ブック...
質問  じゃっかる  - 13/7/29(月) 10:55 -

引用なし
パスワード
   kanabun さま

たくさんのレスありがとうございます。
ご教授をもとに下記の通り書いてみましたが、抽出元AブックのデータもB、C・・・ブックのデータも、出力先の同じセルに出力され、次々に上書きされているようです。
Aブックのデータの下にBブックのデータを出力したいのです。
どこかにcnt=cnt+1的なコードを入れないといけないと思うですがわかりません・・。
お手数ですがご教授願います。


Sub Try1()
 Dim myFolder As String
 'フォルダ選択
  
  Dim oFolder As Object
  Const BIF_RETURNNONLYFSDIRS = &H1  'ディレクトリのみ選択可
  Const BIF_EDITBOX = &H10      'アイテム名入力用のEdit_boxを表示
  Const BIF_FILES = &H4000      'ファイルも表示して選択できる
  Dim hWnd As Long
  
  hWnd = Application.hWnd
  With CreateObject("Shell.Application")
   Set oFolder = .BrowseForFolder(hWnd, _
         "フォルダを選択して下さい", _
         BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX Or BIF_FILES, _
         CreateObject("WScript.Shell").SpecialFolders("DeskTop"))
   If (oFolder Is Nothing) Then Exit Sub
   myFolder = oFolder.Self.Path
  End With
  If Right$(myFolder, 1) <> "\" Then myFolder = myFolder & "\"
 
 'サブフォルダを含むxlsファイルの検索
  Dim Filename As String
  Dim FoundFiles() As String
  Dim tmpPath As String
  Dim sCmd As String
  Dim ko As Long
  
  '---- Dirコマンドによるサブフォルダを含むファイル名の検索
  Filename = myFolder & "*.xls"
  tmpPath = Environ$("Temp") & "\Dir.tmp" '一時ファイルパス

  sCmd = "DIR """ & Filename & """ /b/s/a:-D > """ & tmpPath & """"
           '' /b ファイル名のみ
           '' /s サブディレクトリも検索
           '' /a:-D サブディレクトリー名は表示しない

  With CreateObject("WScript.Shell")
    ko = .Run("CMD /C " & sCmd, 7, True) 'Dirコマンド実行(tmpファイルに出力)
  End With
  If ko Then
    MsgBox "ファイルの検索に失敗しました", , Filename
    Exit Sub
  End If
  If FileLen(tmpPath) < 2 Then Exit Sub 'ファイルが見つからなかった

  '----- Dirコマンドで取得したファイル名を配列に格納
  Dim io As Integer
  Dim buf() As Byte
  io = FreeFile()
  Open tmpPath For Binary As io
   ReDim buf(1 To LOF(io))
   Get #io, , buf
  Close io
  Kill tmpPath
  FoundFiles() = Split(StrConv(buf, vbUnicode), vbCrLf)
  ko = UBound(FoundFiles)
  ReDim Preserve FoundFiles(ko - 1)
     
 
  'Bookごとの処理
  Dim cnt As Long: cnt = 1
  Dim book
  Dim ws As Worksheet
 
  For Each book In FoundFiles
    With Workbooks.Open(book)
      On Error Resume Next
      Set ws = .Worksheets("1枚目")
      On Error GoTo 0
      If ws Is Nothing Then
        MsgBox "このBookには指定シートがありません"
      Else
        With ThisWorkbook.Sheets(1)
          .Cells(cnt, 1).Value = ws.Range("At1").Value
          .Cells(cnt, 2).Value = ws.Range("g8").Value
        End With
        Set ws = Nothing
      End If
      .Close False
    End With
  Next
  MsgBox "まとめ処理終了", , myFolder
End Sub

【74579】Re:フォルダ(サブフォルダ含)内ブック...
発言  kanabun  - 13/7/29(月) 12:17 -

引用なし
パスワード
   ▼じゃっかる さん:

> 抽出元AブックのデータもB、C・・・ブックのデータも、出力先の同じセルに出力され、次々に上書きされているようです。

>どこかにcnt=cnt+1的なコードを入れないといけないと思うですが

失礼。修正時、忘れてました m(_ _)m

>  'Bookごとの処理
  Dim cnt As Long  '◆ここを修正
>  Dim book
>  Dim ws As Worksheet
> 
>  For Each book In FoundFiles
>    With Workbooks.Open(book)
>      On Error Resume Next
>      Set ws = .Worksheets("1枚目")
>      On Error GoTo 0
>      If ws Is Nothing Then
>        MsgBox "このBookには指定シートがありません"
>      Else
>        With ThisWorkbook.Sheets(1)
           cnt = cnt + 1     ’◆一行追加
>          .Cells(cnt, 1).Value = ws.Range("At1").Value
>          .Cells(cnt, 2).Value = ws.Range("g8").Value
>        End With
>        Set ws = Nothing
>      End If
>      .Close False
>    End With
>  Next
>  MsgBox "まとめ処理終了", , myFolder
>End Sub

【74580】Re:フォルダ(サブフォルダ含)内ブック...
お礼  じゃっかる  - 13/7/29(月) 14:48 -

引用なし
パスワード
   kanabun さま

おかげさまでどうにか求める集計ができそうです。
短期間のうちに丁寧に対応していただきまして本当にありがとうございました。
本当に助かりました。

1423 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free