Excel VBA質問箱 IV

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

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


58704 / 76732 ←次へ | 前へ→

【22751】Re:複数フォルダー・ファイルからのデータ抽出
発言  ichinose  - 05/3/2(水) 11:18 -

引用なし
パスワード
   MAYUMI さん、皆さん、こんにちは。

>わざわざ図を描いていただいてありがとうございます。
>図の通りで問題ありません。ファイルの重複もありません。
>一応過去レスで似たようなものがないか調べていたのですが
>【複数ファイルからのデータ】という例がありました。
この例題コードをちょっと変更してみました。
いかに示すコードは、こんな条件下でテストしました。

"D:\My Documents\TESTエリア\第一四半期"
というフォルダ下に
0001〜0007までの7つのフォルダがあったとします。
この7つのフォルダの中に01.xlsから100.xlsまでの100個のブックが
ランダムに入っているとします。

アクティブシートのA列には、1行目から

    A
1   file
2   01
3   02
4   03
5   04



101 100

というように入力してあるとします。つまり、ブック名の拡張子の前までの名前が
入っています。

A列の書式は、文字列に設定しておいてください。

それぞれのブックのシート名「DATA」というシートのH180の値をB列に設定します。
対象ブックにDATAと言うシートがないとシート選択ダイアログが表示されてしまいます。
DATAというシートが存在する事は条件です。

尚、アクティブシートのC列は作業列として使用しますのでフリーにしておいてください。

'=====================================================================
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\TESTエリア\第一四半期"
'   ↑大元のフォルダを代入しています。ここをフォルダ選択ダイアログを
'   使用してフォルダ選択を行うようにすれば他のフォルダでも可能になる
'   思います。フォルダ選択に関しては過去ログにありますので検索してみて下さい

   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"")"
'      ↑C列数式設定
     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


A列ブック名や大元フォルダ内のフォルダ(ここでいう0001から0007)の数は
増やしてもかまいません。


Excel2000で確認しました。

これを改良すれば何とかなるかもしれません。

0 hits

【22720】複数フォルダー・ファイルからのデータ抽出 MAYUMI 05/3/1(火) 9:51 質問
【22724】Re:複数フォルダー・ファイルからのデータ... IROC 05/3/1(火) 10:26 回答
【22728】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/1(火) 13:09 発言
【22730】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/1(火) 15:15 発言
【22734】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 20:57 発言
【22735】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 21:00 発言
【22736】Re:複数フォルダー・ファイルからのデータ... Hirofumi 05/3/1(火) 21:33 発言
【22739】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/1(火) 22:40 発言
【22751】Re:複数フォルダー・ファイルからのデータ... ichinose 05/3/2(水) 11:18 発言
【22752】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/2(水) 11:44 質問
【22753】Re:複数フォルダー・ファイルからのデータ... kazu 05/3/2(水) 12:49 発言
【22781】Re:複数フォルダー・ファイルからのデータ... MAYUMI 05/3/3(木) 9:45 お礼

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