Excel VBA質問箱 IV

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

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


10272 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【22720】複数フォルダー・ファイルからのデータ抽...
質問  MAYUMI  - 05/3/1(火) 9:51 -

引用なし
パスワード
   少しVBAをかじった程度の者ですが、非常に今困っています。Aという
ファイルがあります。そこには12桁の顧客番号がすでに何社分か入力されて
います。他には基準日・残高・その他・合計がありますがデータそのものは
入力されていません。
それとは別に大フォルダーがあります。これは四半期ごとに作成するので
年に4個作成されます。さらに大フォルダーの中には3桁のグループ番号を
名前にする中フォルダーが20個ほど存在します。さらにその中フォルダー
の中には12桁の顧客番号をファイル名に含むファイルが20個ほど存在
します。この12桁の番号は前に登場したAのファイルに入力されている
顧客番号と同じです。さらにそのファイルの中には顧客のデータが入力された
【DATA】と言うシートが存在します。
何がやりたいかというと、Aというファイルで入力されている顧客番号を
元に、どの四半期の大ファイルかを選択すると末端に存在する各顧客の
【DATA】にある基準日・残高・その他・合計の数字をAのファイルに抽出
したいのです。【DATA】から抜き出す残高等の数字の場所はA1・B2
というように固定されています。ただ複数フォルダーの複数ファイルの
ファイル名に含まれる顧客番号を元にこのような抜き出しは可能なんでしょうか。
教えてください。できるかすらもわからず本当に困っています。よろしく
お願いします。

【22724】Re:複数フォルダー・ファイルからのデー...
回答  IROC  - 05/3/1(火) 10:26 -

引用なし
パスワード
   条件があいまいでなく明確であれば可能ですよ。

【22728】Re:複数フォルダー・ファイルからのデー...
発言  kazu  - 05/3/1(火) 13:09 -

引用なし
パスワード
   書いてある事を図示してみました。

説明の意図としては下図の解釈で間違ってないですかね?

顧客毎のファイルは、いづれかのグループ番号のフォルダの中に存在し、
別のグループ番号のフォルダに重複して存在することは無いと考えていいのでしょうか?
(下に図で言う101 ,103の両方のフォルダに123456789000.XLSが存在することは無いと考えていいのでしょうか?)

仮に重複して同一顧客番号のファイルが多岐のフォルダに渡って存在する場合は、
どの様な基準でどのファイルを参照するのでしょうか?

条件さえ整えば、フォルダ選択 → ファイル検索のフロー及び
その後の【DATA】シートにある・・・・・というのは問題になる程難しい事でも無い気はします。


001 ← 第一四半期
|_______________ 101 ← グループ番号
|         |_______________ 123456789000.XLS
|         |_______________ 123456789001.XLS
|         |_______________ 123456789002.XLS
|         |_______________ 123456789003.XLS
|         |_______________ 123456789004.XLS
|         |_______________ 123456789005.XLS
|         |_______________ 123456789006.XLS
|         |_______________ 123456789007.XLS
|         |_______________ 123456789008.XLS
|         |_______________ 123456789009.XLS
|         |_______________ 123456789010.XLS
|         |_______________ 123456789011.XLS
|         |_______________ 123456789012.XLS
|         |_______________ 123456789013.XLS
|         |_______________ 123456789014.XLS
|         |_______________ 123456789015.XLS
|         |_______________ 123456789016.XLS
|         |_______________ 123456789017.XLS
|         |_______________ 123456789018.XLS
|         |_______________ 123456789019.XLS
|
|_______________ 103
|_______________ 104
|_______________ 105
|_______________ 106
|_______________ 107
|_______________ 108
|_______________ 109
|_______________ 110
|_______________ 111
|_______________ 112
|_______________ 113
|_______________ 114
|_______________ 115
|_______________ 116
|_______________ 117
|_______________ 118
|_______________ 119
|_______________ 120

002 ← 第仁四半期
003 ← 第三四半期
004 ← 第四四半期

【22730】Re:複数フォルダー・ファイルからのデー...
発言  MAYUMI  - 05/3/1(火) 15:15 -

引用なし
パスワード
   わざわざ図を描いていただいてありがとうございます。
図の通りで問題ありません。ファイルの重複もありません。
一応過去レスで似たようなものがないか調べていたのですが
【複数ファイルからのデータ】という例がありました。

Sub test()
  Dim cnt As Long
  Dim r_add1 As String
  Dim sht As String
   cnt = 10
   Range("a1:b1").Value = Array("file", "H180")
   r_add = Range(Range("b1").Value).Address
   For idx = 2 To cnt + 1
    With Cells(idx, 1)
     .Value = idx - 1
     .NumberFormat = "00"
     sht = .Text
     With .Offset(0, 1)
       .Formula = "='" & ThisWorkbook.Path & _
             "\[" & sht & ".xls]" & sht & _
          "'!" & r_add
       '.Value = .Value
       End With
     End With
    Next
End Sub

これだと確かに同じH180のデータを複数ファイルから抜き出せる
ようですが、今回はcntで入力するファイルの数が確定していないうえ
どの番号のファイルが対象かは四半期ごとに変わります。
なおかつコピー先のファイルがコピー元と同じフォルダ内にないと
いけないようですが、コピー先とは分けなければいけません。
素人考えでおそらく上のコードをいじっていけばできるような気は
するのですがどう手をつけて良いかわかりません。よい知恵をお貸しください。

【22734】Re:複数フォルダー・ファイルからのデー...
発言  Hirofumi  - 05/3/1(火) 20:57 -

引用なし
パスワード
   転記元の何処の範囲を、転記先の何処の範囲に、どの様に転記するのか解らないので
取り合えず、指定したフォルダ以下で、指定した顧客番号を含むBook名を取得する
コードをUpします

ただ、Dir関数なので上手くいくか?です
以下を、標準モジュールに記述して下さい

Option Explicit

' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Public Sub Test()

  Dim i As Long
  Dim vntFileName As Variant
  Dim strFolder As String
  Dim strCustomer As String
  
  '顧客番号を取得
  strCustomer = InputBox("顧客番号を12桁で入力して下さい", "顧客番号入力")
  If strCustomer = "" Then
    Exit Sub
  End If
  strCustomer = "*" & strCustomer & "*.xls"
  
  '四半期のフォルダを取得
  strFolder = GetFolderPath
  
  '四半期のフォルダ以下に有る、顧客番号を含むBookを取得
  vntFileName = FilesList(strFolder, strCustomer, True)
  
  '"Sheet1"にBook名を列挙
  With Worksheets("Sheet1")
    If vntFileName(0) <> "" Then
      For i = 0 To UBound(vntFileName)
        .Cells(i + 1, 1).Value = vntFileName(i)
      Next i
    Else
      Beep
      MsgBox "該当するBookが有りません"
    End If
  End With
  
End Sub

Public Function FilesList(ByVal strFilesPath As String, _
              ByVal strSearchFile As String, _
              Optional blnSubDir As Boolean = False) As Variant

  Dim strData() As String
  
  ReDim strData(0)
  ChooseFiles strFilesPath, strSearchFile, strData(), blnSubDir
  
  FilesList = strData()
  
End Function

Private Sub ChooseFiles(ByVal strFilesPath As String, _
            ByVal strSearchFile As String, _
            strData() As String, _
            blnSubDir As Boolean)

  Dim i As Long
  Dim j As Long
  Dim strFileName As String
  Dim strDirList() As String

  '結果用配列の書き込み位置を取得
  If strData(UBound(strData)) = "" Then
    i = UBound(strData)
  Else
    i = UBound(strData) + 1
  End If
  'パスの最後に\を付加
  If Right(strFilesPath, 1) <> "\" Then
    strFilesPath = strFilesPath & "\"
  End If
  
  'ディレクトリ内の全ての標準ファイルを列挙
  strFileName = Dir(strFilesPath & strSearchFile)
  Do Until strFileName = ""
    ReDim Preserve strData(i)
    strData(i) = strFilesPath & strFileName
    i = i + 1
    strFileName = Dir
  Loop

  If blnSubDir Then
    'サブディレクトリの一時的なリストを作成
    strFileName = Dir(strFilesPath, vbDirectory)
    Do Until strFileName = ""
      '現在のディレクトリと親ディレクトリを無視
      If strFileName <> "." And strFileName <> ".." Then
        'ディレクトリ以外を無視
        If GetAttr(strFilesPath & strFileName) _
                      And vbDirectory Then
          j = j + 1
          ReDim Preserve strDirList(j)
          strDirList(j) = strFilesPath & strFileName
        End If
      End If
      strFileName = Dir
    Loop
    '各ディレクトリを再帰処理
    For i = 1 To j
      ChooseFiles strDirList(i), strSearchFile, strData(), True
    Next i
  End If
  
End Sub

Private Function GetFolderPath() As String

  Dim strTitle As String
  Dim objFolder As Object
  Dim hWnd As Long
  Dim strTmpPath As String
  Const BIF_RETURNONLYFSDIRS = &H1
  Const ssfDESKTOP = &H0
  Const CSIDL_WINDOWS = &H24
  
  'アクティブなWindowのハンドルを取得
  hWnd = GetForegroundWindow
  ' 表示タイトルを指定
  strTitle = "四半期のフォルダを選択して下さい"
  ' フォルダ選択ダイアログを表示
  Set objFolder = CreateObject("Shell.Application"). _
              BrowseForFolder(hWnd, strTitle, _
                BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
  ' フォルダを選択したときは
  If Not (objFolder Is Nothing) Then
    ' 選択フォルダを表示
    With objFolder
      ' 親フォルダが存在するときは
      If Not (.ParentFolder Is Nothing) Then
        ' 選択フォルダのフルパスを表示
        strTmpPath = .Items.Item.Path
      ' 親フォルダのときは
      Else
        ' フォルダ名を表示
        strTmpPath = .Title
      End If
    End With
    ' Folderオブジェクトを破棄
    Set objFolder = Nothing
  End If
  
  If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
    strTmpPath = strTmpPath & "\"
  End If

  GetFolderPath = strTmpPath
  
End Function

此れにより、「Sub Test」の中のvntFileName変数に該当するBook名が取得されますので
これをLoopして、転記していけば善いのでは?

【22735】Re:複数フォルダー・ファイルからのデー...
発言  Hirofumi  - 05/3/1(火) 21:00 -

引用なし
パスワード
   書き忘れましたが、このコードを実行すると、
Sheet1のA列に該当するBook名が、フルパスで列挙されます

【22736】Re:複数フォルダー・ファイルからのデー...
発言  Hirofumi  - 05/3/1(火) 21:33 -

引用なし
パスワード
   ゴメン!、以下の修正をして下さい
このままだと、フォルダ選択でキャンセルすると、おかしく成る

「Public Sub Test()」の中の

  '四半期のフォルダを取得
  strFolder = GetFolderPath
  If strFolder = "" Then '★この行追加
    Exit Sub      '★この行追加
  End If         '★この行追加

【22739】Re:複数フォルダー・ファイルからのデー...
発言  kazu  - 05/3/1(火) 22:40 -

引用なし
パスワード
   MAYUMI さん

回答ついてるみたいなんで、不要かもですが・・・。

BookAが以下の様になっている状態で、Book1のシート名が Sheet1 であれば
以下のコードでもいけると思います。

各パラメータは以下の通りですので、コード中の各値を変えれば動くと思いますが・・・。

各顧客用Bookのデータの入ってるシート名
Const StrTmpSht As String = "DATA"   

BookAの書き出し用(顧客コードのかいてある)シート名
Const StrWriteSht As String = "Sheet1"
顧客コードのかいてある)列番号(アルファベット)
Const StrColId As String = "A"

各顧客用Bookのデータの基準日のセル位置
Const Str基準日 As String = "A1"
各顧客用Bookのデータの残高のセル位置
Const Str残高 As String = "A2"
各顧客用Bookのデータのその他のセル位置
Const Strその他 As String = "A3"
各顧客用Bookのデータの合計のセル位置
Const Str合計 As String = "A4"


       A        B     C     D     E
1     顧客コード  基準日   残高   その他   合計
2    1234567890
3    1234567891
4    1234567892
5
6
7
8
9






Sub Sample()

Const StrTmpSht As String = "DATA"
Const StrWriteSht As String = "Sheet1"
Const StrColId As String = "A"

Const Str基準日 As String = "A1"
Const Str残高 As String = "A2"
Const Strその他 As String = "A3"
Const Str合計 As String = "A4"

Set MyWsh = CreateObject("Shell.Application")
'どのフォルダを対象にするかを選定
Set myFolder = MyWsh.BrowseForFolder(0, "フォルダを指定してください", 0)
If Not myFolder Is Nothing Then
  MyPath = myFolder.Self.Path
  Set MyWsh = Nothing
  Set MyWsh = CreateObject("Scripting.FileSystemObject")
  Set myFolder = MyWsh.GetFolder(MyPath).SubFolders
  
  For Each Cel In ThisWorkbook.Sheets(StrWriteSht).Columns(StrColId).Cells
    If Cel.Row = ThisWorkbook.Sheets(StrWriteSht).Range(StrColId & 65000).End(xlUp).Row + 1 Then Exit For
    If Cel.Value <> "" And Cel.Row <> 1 And Cel.Value <> "" Then
      For Each Fld In myFolder
        Set myFile = MyWsh.GetFolder(Fld).Files
        SeekFile = ""
        For Each Fil In myFile
          If StrConv(Fil.Name, vbNarrow + vbLowerCase) Like Cel & "*.xls" Then
            SeekFile = Fil.Path
            Exit For
          End If
        Next
        If SeekFile <> "" Then
          Workbooks.Open SeekFile, False, True
          Flg = False
          For Each Sht In ActiveWorkbook.Sheets
            If Sht.Name = StrTmpSht Then Flg = True: Exit For
          Next
          
          If Flg Then
            Cel.Offset(0, 1).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str基準日).Text
            Cel.Offset(0, 2).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str残高).Value
            Cel.Offset(0, 3).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Strその他).Value
            Cel.Offset(0, 4).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str合計).Value
          Else
            MsgBox "反映用シートが存在しません"
          End If
          
          Set Sht = Nothing
          ActiveWorkbook.Close False
        End If
      Next
    End If
  Next
Else
  MsgBox "フォルダを選択してから実行して下さい。" & vbCrLf & _
      "処理を中止します。", vbOKOnly + vbExclamation, "フォルダ未選択"
End If

End Sub

【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で確認しました。

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

【22752】Re:複数フォルダー・ファイルからのデー...
質問  MAYUMI  - 05/3/2(水) 11:44 -

引用なし
パスワード
   みなさん本当にありがとうございます。いろいろやってみてKAZUさんの
コードを参考にしてみました。当然セルの位置の変更等は行いましたが
まさに私のやりたかったことができました。ありがとうございます。
ただちょっと引っ掛かりがありまして、各顧客ファイルの名前に顧客
コードが含まれそこからデータを読みにいくはずだったんですが、
ファイル名がずばり顧客コードじゃないとデータを読みにいってくれません。

  For Each Cel In ThisWorkbook.Sheets(StrWriteSht).Columns(StrColId).Cells
    If Cel.Row = ThisWorkbook.Sheets(StrWriteSht).Range(StrColId & 65000).End(xlUp).Row + 1 Then Exit For
    If Cel.Value <> "" And Cel.Row <> 1 And Cel.Value <> "" Then
      For Each Fld In myFolder
        Set myFile = MyWsh.GetFolder(Fld).Files
        SeekFile = ""
        For Each Fil In myFile
If StrConv(Fil.Name, vbNarrow + vbLowerCase) Like Cel & "*.xls" Then ・・・・・

おそらくこのコードの"*.xls"を単純に何かに変更すれば解決するような気が
するんですがうまい方法は何かあるでしょうか?

【22753】Re:複数フォルダー・ファイルからのデー...
発言  kazu  - 05/3/2(水) 12:49 -

引用なし
パスワード
   MAYUMI さん
現状、前方一致になっていますので、
含むにする為には以下を変更して下さい。

詳細はLikeのHelpを参照下さい。
If StrConv(Fil.Name, vbNarrow + vbLowerCase) Like Cel & "*.xls" Then

If StrConv(Fil.Name, vbNarrow + vbLowerCase) Like "*" & StrConv(Cel, vbNarrow + vbLowerCase) & "*.xls" Then

【22781】Re:複数フォルダー・ファイルからのデー...
お礼  MAYUMI  - 05/3/3(木) 9:45 -

引用なし
パスワード
   本当にありがとうございました。
他にも細かい修正はありますが勉強になるので自分でできるところまで
がんばってみます。
あまりここに来る機会はないんですが、もし何かありましたら今後も
よろしくお願いします。

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