| |
ＭＡＹＵＭＩ さん、皆さん、こんにちは。
>わざわざ図を描いていただいてありがとうございます。
>図の通りで問題ありません。ファイルの重複もありません。
>一応過去レスで似たようなものがないか調べていたのですが
>【複数ファイルからのデータ】という例がありました。
この例題コードをちょっと変更してみました。
いかに示すコードは、こんな条件下でテストしました。
"D:\My Documents\ＴＥＳＴエリア\第一四半期"
というフォルダ下に
0001〜0007までの7つのフォルダがあったとします。
この7つのフォルダの中に01.xlsから100.xlsまでの100個のブックが
ランダムに入っているとします。
アクティブシートのＡ列には、1行目から
Ａ
１ file
２ 01
３ 02
４ 03
５ 04
・
・
・
１０１ 100
というように入力してあるとします。つまり、ブック名の拡張子の前までの名前が
入っています。
Ａ列の書式は、文字列に設定しておいてください。
それぞれのブックのシート名「DATA」というシートのH180の値をＢ列に設定します。
対象ブックにDATAと言うシートがないとシート選択ダイアログが表示されてしまいます。
DATAというシートが存在する事は条件です。
尚、アクティブシートのＣ列は作業列として使用しますのでフリーにしておいてください。
'=====================================================================
Sub main()
Dim fso As Object
Dim s_flds As Object
Dim s_fld As Object
Dim rng As Range
Dim rng2 As Range
Dim err_rng As Range
On Error Resume Next
Range("a1:b1").Value = Array("file", "H180")
' ↑ここをA1にすれば、A1を参照します
Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
Application.DisplayAlerts = False
If rng.Count > 1 Then
fldnm = "D:\My Documents\ＴＥＳＴエリア\第一四半期"
' ↑大元のフォルダを代入しています。ここをフォルダ選択ダイアログを
' 使用してフォルダ選択を行うようにすれば他のフォルダでも可能になる
' 思います。フォルダ選択に関しては過去ログにありますので検索してみて下さい
Set fso = CreateObject("Scripting.FileSystemObject")
Set s_flds = fso.GetFolder(fldnm).SubFolders
Add = Range(Range("b1").Value).Address(, , xlR1C1)
Set rng2 = Range("a2", Cells(Rows.Count, 1).End(xlUp))
Set err_rng = rng2
For Each s_fld In s_flds
t_path = fldnm & "\" & s_fld.Name
With err_rng
.Offset(0, 2).Formula = "=""=""&ADDRESS(row(" & Add & _
"),column(" & Add & _
"),,,""" & _
t_path & _
"\[""&rc[-2]&"".xls]data"")"
' ↑Ｃ列数式設定
For Each r_tmp In .Offset(0, 1).Cells
r_tmp.Formula = r_tmp.Offset(0, 1).Value
Next
Err.Clear
Set err_rng = rng.Offset(0, 1).SpecialCells(xlCellTypeFormulas, xlErrors)
If Err.Number <> 0 Then Exit For
' 参照エラーが無くなったら終了
Set err_rng = err_rng.Offset(0, -1)
End With
Next
With rng
.Formula = .Formula
.Offset(0, 2).Value = ""
.Offset(0, 1).SpecialCells(xlCellTypeFormulas, xlErrors).Value = ""
.Offset(0, 1).Value = .Offset(0, 1).Value
End With
Set fso = Nothing
Set s_flds = Nothing
Set s_fld = Nothing
End If
Application.DisplayAlerts = True
End Sub
Ａ列ブック名や大元フォルダ内のフォルダ（ここでいう0001から0007）の数は
増やしてもかまいません。
Excel2000で確認しました。
これを改良すれば何とかなるかもしれません。
|
|
ichinose
- 05/3/2(水) 11:18 -
