Excel VBA質問箱 IV

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

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


7741 / 76734 ←次へ | 前へ→

【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

9 hits

【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 お礼

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