[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ファイルから特定のセルの一覧表』（あんころもち）
複数の同フォームファイルから特定のセルデータを抽出したいのですが 何か良い方法は無いでしょうか。 フォルダ形態は年－月－日 となっておりファイル名はばらばらです。 例 『2011』 ∟『06』 ∟『03.xls』 ∟『04そのいち.xls』 みたいな感じです。 その中でシート名が『限定』となっているシートのセルC21とG24と シート名が『特定』となっているシートのセルC20の一覧表を作成したいのですが、 一つずつファイルを開くのが面倒なんでよい方法が有りましたら教えてください。 ファイル数は5年分で約1500ほど有ります。 Excel2003です。 よろしくお願いします。
まず、関数というか、シート上の設定で？ それともＶＢＡでもいい？ 次に、「一つずつファイルを開くのが面倒」、これは人間が1500ファイル開くと「面倒」だけど ＶＢＡにやらせれば、別に「面倒」ではないね。開いていることを気づかせずに処理すればいいのか それとも、「絶対に開かないで処理したい」のか、そこは、どうですか？
もう１つ追加質問
フォルダ内の各ブックには、「必ず」『限定』シートと『特定』シートがある？ それとも、１つしかない、あるいは全くないものもある？
ぶらっと立ち寄り
ありがとうございます。 手段は何でもいいです。 その一覧表を作成し、ファイルの精査をしたいので マクロ？VBA？ハイパーリンク？何らかの手法で一覧表が作成できたら ありがたいのです。 VBAで一覧表作成の時間が掛かっても関数でそのファイルが重たくなっても 一覧表が作成でき精査が終われば消します。 ブックにはそのシートが無いものも混じっています。 よろしくお願いします。（あんころもち）
> フォルダ形態は年－月－日 となっておりファイル名はばらばらです。 > 例 『2011』 > ∟『06』 > ∟『03.xls』 > ∟『04そのいち.xls』 みたいな感じです。
この説明がわかりずらいので、サブフォルダ全てにループしています。
Sub test()
Dim myDir As String, myList
myDir = "ここに親フォルダのパス"
myList = SearchFiles(myDir, "*.xls*")
If IsArray(myList) Then
GetInfo myList
Else
MsgBox "No files found"
End If
End Sub
Function SearchFiles(myDir As String, myFileName As String) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Dim myList() As String, n As Long
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.GetFolder(myDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) * (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = myDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.GetFolder(myDir).SubFolders
SearchFiles myDir & "\" & myFolder.Name, myFileName
Next
SearchFiles = IIf(n > 0, myList, 0)
End Function
Private Sub GetInfo(myList)
Dim i As Long, wsName As String, t As Long, x, mySheets, e
mySheets = Array(Array("限定", "R21C3", "R24C7"), Array("特定", "r20c3"))
With ThisWorkbook.Sheets(1)
.Cells.Clear
.Cells(1, 1).Resize(, 4).Value = _
Array("ファイル パス", mySheets(0)(0) & "!C21", mySheets(0)(0) & "!G24", mySheets(1)(0) & "!C20")
t = 1
For i = 1 To UBound(myList, 2)
x = ExecuteExcel4Macro("'" & myList(1, i) & "\[" & myList(2, i) & "]" & w(0)(0) & "'!R1C1")
y = ExecuteExcel4Macro("'" & myList(1, i) & "\[" & myList(2, i) & "]" & w(1)(0) & "'!R1C1")
If (Not IsError(x)) + (Not IsError(y)) Then
t = t + 1
.Cells(t, 1).Value = myList(1, i) & "\" & myList(2, i)
If Not IsError(x) Then
.Cells(t, 2).Resize(, 2).Formula = _
Array("='" & myList(1, i) & "\[" & myList(2, i) & "]" & w(0)(0) & "'!" & w(0)(1), _
"='" & myList(1, i) & "\[" & myList(2, i) & "]" & w(0)(0) & "'!" & w(0)(2))
End If
If Not IsError(y) Then
.Cells(t, 4).Formula = "='" & myList(1, i) & "\[" & myList(2, i) & "]" & w(1)(0) & "'!" & w(1)(1)
End If
End If
Next
.Range("a1:d1").EntireColumn.AutoFit
End With
End Sub
(seiya)
抽出時の不具合を修正 13:58
seiyaさんとはちょっと方式が違うところもあるのでコードをアップ。 サブプロシジャのgetSheetNameについてはネットに掲載された、あれやこれやを踏まえているので もしかしたら、著作権侵害の可能性もあるけど・・・・ seiyaさんと同じく、ブックを開かずに処理。参照するフォルダパスや転記シート情報については 実態に合わせてチューニングしてね。 なお、ファイルを開かないでファイル名を抽出するには、いろんな方法があるけど、ここでは、コードが簡単になるので それらの中で「一番遅い」FSOを使っている。
Sub Sample()
Dim myPool As Collection
Dim wk As Variant
Dim stFolder As String
Dim objFSO As Object
Dim shV As Variant
Dim shN As Variant
Dim shX As Variant
Dim myCell As Range
Dim myPath As String
Dim myBook As String
With ThisWorkbook.Sheets("Sheet1") '転記シート 適宜変更
.Cells.Clear
Set myCell = .Range("A1") '転記開始セル 適宜変更
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myPool = New Collection
stFolder = ThisWorkbook.Path & "\2011\" '開始フォルダ 適宜変更
Call FileList(objFSO.GetFolder(stFolder), myPool)
For Each wk In myPool
wk = Split(wk, vbTab)
myPath = wk(0)
myBook = wk(1)
shV = getSheetName(myPath & "\" & myBook)
For Each shN In Array("限定", "特定")
shX = Application.Match(shN, shV, 0)
If IsNumeric(shX) Then
Select Case shN
Case "特定"
myCell.Value = "='" & myPath & "\[" & myBook & "]" & shN & "'!C20"
Case "限定"
'C21,C24
myCell.Value = "='" & myPath & "\[" & myBook & "]" & shN & "'!C21"
Set myCell = myCell.Offset(1)
myCell.Value = "='" & myPath & "\[" & myBook & "]" & shN & "'!C24"
End Select
Set myCell = myCell.Offset(1)
End If
Next
Next
With ThisWorkbook.Sheets("Sheet1") '転記シート 適宜変更
'.Cells.Value = .Cells.Value '値に変更
End With
Set objFSO = Nothing
Set myPool = Nothing
End Sub
Private Sub FileList(objFD As Object, fPool As Collection)
Dim objTarget As Object
Dim objSFD As Object
'ファイル名を列挙
For Each objTarget In objFD.Files
fPool.Add objTarget.parentfolder & vbTab & objTarget.Name
Next
'サブフォルダを検索
For Each objSFD In objFD.subfolders
Call FileList(objSFD, fPool)
Next
End Sub
Private Function getSheetName(wbName As String) As Variant
Const adSchemaTables As Long = 20
Dim adoCn As Object
Dim adoRs As Object
Dim shName As String
Dim chk As String
Dim j As Long
Dim x()
j = 1
On Error Resume Next
Set adoCn = CreateObject("ADODB.Connection")
adoCn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbName & ";" & _
"Extended Properties=Excel 8.0;")
Set adoRs = adoCn.OpenSchema(adSchemaTables)
Do Until adoRs.EOF
If adoRs Is Nothing Then Exit Do
shName = adoRs.Fields("TABLE_NAME").Value
chk = Right$(shName, 1)
If chk Like "$" Or chk Like "'" Then
ReDim Preserve x(1 To j)
x(j) = Left$(shName, Len(shName) - 1)
j = j + 1
End If
adoRs.MoveNext
Loop
adoRs.Close
Set adoRs = Nothing
adoCn.Close
Set adoCn = Nothing
getSheetName = x
End Function
ぶらっと立ち寄り
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.