| |
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
|
|
じゃっかる
- 13/7/29(月) 10:55 -
