Excel VBA質問箱 IV

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

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


58716 / 76732 ←次へ | 前へ→

【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
1 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 お礼

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