[[20190721131304]]　『フォルダ内にある全ファイルの特定セルの転記方法』（VBA勉強中）　ページの最後に飛ぶ

『フォルダ内にある全ファイルの特定セルの転記方法』（VBA勉強中）

「7月1日」というフォルダの中に、ファイル名の違うデータファイルが50個ある。
抽出したいのはD列のデータ。D列には◯が入っていたり空白の時もある。
D列のデータを別ファイルに転記し、各項目の合計を求めたい。
また、ファイル名も転記したい。
将来的には日次の集計の他に、月次の集計も取りたい。
どのようなプログラムを書くのが1番簡単でしょうか？

フォルダ名:7月1日
ファイル名:123456, 324567, 345678, 654321.....

    C列                   D列
   趣味             当てはまる
1  ゴルフ              ◯
2  水泳
3  マラソン            ◯
4  野球      
.
.
.
50 旅行               ◯

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

簡単かはわかりませんが

 (1)Dir関数をつかって「7月1日」フォルダのうち「*.xls?」ファイルを片っ端から取得

 (2)集計用の（ブックの集計用の）シートのC列最終行を求める
 (3)(1)のブックを開いて【データがあるシートを指定して】C～D列をコピーする
 (4)(2)で求めた【セル】の1行下に(3)を貼付する

 (5)(2)～(4)を繰り返す
 (6)作業用シートに、集計用の（ブックの集計用の）シートのC1～C列最終行までをコピーする
 (7)(6)に対して重複の削除を使って、重複のない「項目」のリストを作成
 (7)に対してSUMIF関数などを使って、「各項目」の集計を行う。

という感じでどうでしょうか？

個々の箇所で分からない場合は、現状のコードを示し、どこでどのようなエラーが出てしまうのか、エラーにならない場合でも、どのような結果になるはずが、どのような結果になってしまったのかを提示して頂くと、アドバイスできることがあるかもしれません。

ただ単に完成品がほしいという場合は、他の回答者さんをお待ちください。

（もこな２） 2019/07/21(日) 14:03

もこな2さん、ありがとうございます。
私VBAは全くの初心者のため、完成品のが助かります。
他の回答を待つ事に致します。
（VBA勉強中） 2019/07/21(日) 14:06

 1)各ファイルのシート名は共通、又は関連性があるか
 2) >D列のデータを別ファイルに転記し、各項目の合計を求めたい.
 具体的にわからない。

 データが要件を満たしていればADO接続が簡単。
（seiya） 2019/07/21(日) 14:18

質問の意味の確認です

＞抽出したいのはD列のデータ。D列には◯が入っていたり空白の時もある。

◯だけを抽出したいということ？

＞D列のデータを別ファイルに転記し、各項目の合計を求めたい。

数値が入っているわけではないので、合計はできないと思いますが
○の個数ということですか？

＞また、ファイル名も転記したい。
どこに・・

イメージされている完成予想図を提示されたほうが
レスはつきやすいと思います。

それと肝心なことですが、各ファイルのシート数は１つですか？

（渡辺ひかる） 2019/07/21(日) 14:31

○を抽出し、それが何個あるか合計を出したいです。
シート数は各１つ、シート名は同じです。
「７月１日」フォルダの中にあるファイル名も転記したいです。
素人の説明でわかりにくいかもしれませんが、下記のようなイメージです。

　　　ファイル名　データ1　データ2　データ3　データ4・・

合計 No. 趣味　　　　

3 　　 1 　ゴルフ　　 ○　　　　　　　　　○　　　　○
2 　　 2 　水泳　　　　　　　　　○　　　　○
1 　　 3 　マラソン　　○ 　
1 　　 4 　野球　　　　　　　　　　　　　　　　　　　○
0 　　・　・
0 　　・　・
0 　　・　・
4 　　 50　旅行　　　　○　　　○　　　　 ○　　　　○

（VBA勉強中） 2019/07/21(日) 19:22

 各ファイルSheet1(仮の名前)の列項目に 趣味 当てはまる の2つの項目が必ず存在し○が入力されている趣味を抽出
 集計シート(ActiveSheet)のC列に趣味のカテゴリーが既に列挙されていてD列から順に該当行に○を記入

 ということで

 Sub test()
    Dim myDir As String, fn As String, x, y, t As Long, i As Long, txt As String
    Dim cn As Object, rs As Object, myList As Range
    Const wsName As String = "Sheet1" '<--------------要変更・シート名
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    Set myList = Range("c1", Range("c" & Rows.Count).End(xlUp))
    fn = Dir(myDir & "*.xls")
    If fn = "" Then Exit Sub
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=Yes;"
        .Open myDir & fn
    End With
    t = 3
    Range("d1", Cells.SpecialCells(11)).ClearContents
    Do While fn <> ""
        txt = IIf(t > 3, "In '" & myDir & fn & "' 'Excel 12.0;''HDR=Yes;IMEX=1;'''", "")
        rs.Open "Select `趣味`, `当てはまる` From `" & wsName & "$` " & txt & _
                " Where `当てはまる` = '◯';", cn, 3, 3, 1
        t = t + 1
        Cells(1, t) = fn
        If rs.RecordCount Then
            x = rs.GetRows
            For i = 0 To UBound(x, 2)
                y = Application.Match(x(0, i), myList, 0)
                If IsNumeric(y) Then Cells(y, t).Value = "○"
            Next
        End If
        rs.Close
        fn = Dir
    Loop
    Set cn = Nothing: Set rs = Nothing
End Sub
（seiya） 2019/07/21(日) 20:34

seiyaさん、ありがとうございます。
しかしながら、素人にはこのプログラムを書き換えて使う技術がありませんでした・・・
趣味の欄は数行のセルが結合されている箇所もありますが、ずれませんでしょうか。

元ファイルは下記のような感じで、ファイル名も別の離れたセルに入っています。

　　　　　　　　　　　　　　ファイル名　データ１

No. 趣味　　　　

1 　ゴルフ　　　　○　　　　　　　　　
2 　水泳　　　　　　　　　
3 　マラソン　　　　○ 　
4 　野球　　　　　　　　　　　　　　　　　　　
5
6
7　料理
　　・　
　　・
50　旅行　　　　　 ○　

（VBA勉強中） 2019/07/21(日) 21:10

 まず自分で書き換えることは考えずに、データの配置をきちんと正確に提示することから始めた方が
 無駄な時間を過ごすことをなくすことができると思います。

 まず各シートのレイアウトを正確に提示することをお勧めします。
 どなたかが、あなたにも変更できるコードを書いてくれるかも知れません。
（seiya） 2019/07/21(日) 21:20

実際の元データのレイアウトは

ファイル名（管理番号）がB2。
転記したい「○」の項目がD6からD50まであり、このRangeで1行ずつ抽出したいです。
この2つさえ転記できれば、あとは関数で○の数をカウントしようかと思っています。
（また、転記する時点でカウント数を入れられるなら尚良いとも思っています。）

フォルダの中にマクロファイルを入れ、その階層にデータファイルを入れるフォルダを作成し、元データの場所をハイパーリンクと同じ要領で”C:\マクロ\元データ\”などと指定すれば良いのでしょうか？

（VBA勉強中） 2019/07/21(日) 21:39

 管理番号がB2、データが6行目からで 趣味は C列 当てはまる はD列
 出力先シートのA列にカウント,C列にC2から趣味のカテゴリーが列挙、
 D列から出力、1行目にファイル名、該当行に○

 という理解でよいですか？

 管理番号はどこかに出力する必要がありますか？

（seiya） 2019/07/21(日) 22:05

管理番号は19:22に書きました「データ1」「データ2」とかの部分に出力したいです。
（VBA勉強中） 2019/07/22(月) 06:53

 下記コードを貼り付けたブックを同じフォルダに保存してから実行してください。
 もし不具合が出た場合は何がどうしたのか、エラーが出た場合は行でどのようなエラーメッセージかを
 できるだけ詳細に伝えてください。

 Sub test()
    Dim myDir As String, fn As String, x, y, t As Long, i As Long, txt As String
    Dim cn As Object, rs As Object, myList As Range
    Const wsName As String = "Sheet1" '<--------------要変更・シート名
    myDir = ThisWorkbook.Path & "\"
    Set myList = Range("c1", Range("c" & Rows.Count).End(xlUp))
    fn = Dir(myDir & "*.xls")
    If fn = "" Then Exit Sub
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=No;"
        .Open myDir & fn
    End With
    t = 3
    Columns("d").Resize(, Application.Max(1, Cells.SpecialCells(11).Column - 3)).ClearContents
    Cells(1).CurrentRegion.Offset(1).Columns(1).ClearContents
    Do While fn <> ""
        If fn <> ThisWorkbook.Name Then
            txt = IIf(t > 3, "In '" & myDir & fn & "' 'Excel 12.0;''HDR=No;IMEX=1;'''", "")
            rs.Open "Select F1, F2 From `" & wsName & "$C6:D100` " & txt & _
                    " Where F2 = '◯';", cn, 3, 3, 1
            t = t + 1
            Cells(1, t) = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & wsName & "'!r2c2")
            If rs.RecordCount Then
                x = rs.GetRows
                For i = 0 To UBound(x, 2)
                    y = Application.Match(x(0, i), myList, 0)
                    If IsNumeric(y) Then
                        Cells(y, t).Value = "○"
                        Cells(y, 1).Value = Cells(y, 1).Value + 1
                    End If
                Next
            End If
            rs.Close
        End If
        fn = Dir
    Loop
    Set cn = Nothing: Set rs = Nothing
End Sub

（seiya） 2019/07/22(月) 08:44

単純にコピペで書いてみました
お試しください

なお、対象フォルダ内には、データファイルのみで、すべてのレイアウトが同じという前提です
集計シートのA列の数式は、ご自分で。

Sub test22()

    Dim myFso As Object ' Scripting.FileSystemObject
    Dim myFile As Object 'Scripting.File
    Dim myTosht As Worksheet
    Dim myFlg As Boolean
    Dim i As Long
    Const myPath As String = "C:\Users" '対象フォルダ,適宜変更

    Set myFso = CreateObject("Scripting.FileSystemObject")

    Set myTosht = ThisWorkbook.Worksheets(1) '集計シート
    myTosht.Cells.Clear

    myFlg = False
    i = 0

    For Each myFile In myFso.GetFolder(myPath).Files
        With Workbooks.Open(myFile.Path)
            With .Worksheets(1)
                If myFlg = False Then '最初だけC列コピー
                    .Range("C6:C50").Copy myTosht.Range("C6:C50")
                    myFlg = True
                End If
                .Range("B2").Copy myTosht.Range("D2").Offset(, i)
                .Range("D6:D50").Copy myTosht.Range("D6:D50").Offset(, i)
            End With
            .Close False
        End With
        i = i + 1
    Next
End Sub

（渡辺ひかる） 2019/07/22(月) 09:46
10:28 冗長分修正

 こんばんは　＾＾
なが～いコードになってしまいました。。。　＾＾；
＞＞Ｃ列がマージされている
が気になるのですが。Ｄ列に○がある場合、Ｄ列がおなじ行分、マージされているか、Ｃ列のマージセルの
一番上の行位置と同じＤ列の行に○があれば良いのですが、それ以外はサポートしていません。もうひと工夫
必要ですが。。。この辺りはご本人様が調整されるのが一番ですね。。。A^_^;
集計用の（マクロ）ブックがあるフォルダのサブフォルダ　７月１日　にデータファイル（ブック）が
ある。が、前程です。

 Option Explicit
Sub OneInstance01()
    '要、参照 Microsoft Scripting Runtime
    Dim Fd As String
    Dim Inf As Object
    Dim Fs As Object
    Dim D As Object
    Dim Wb As Workbook
    Dim Pcnt As Long
    Dim i As Long
    Dim y As Long
    Dim Base As Variant
    Dim rr As Range
    Dim Midasi()
    Dim Retu()
    Fd = ThisWorkbook.Path & "\" & "7月1日\"
    If Not Evaluate("=ISREF(TMP!A1)") Then Sheets.Add.Name = "TMP"
    Set Fs = New FileSystemObject
    Set D = CreateObject("Scripting.Dictionary")
    ReDim Midasi(1 To Fs.GetFolder(Fd).Files.Count)
    With Worksheets("TMP")
        .Cells.Delete
        For Each Inf In Fs.GetFolder(Fd).Files
            Set Wb = GetObject(Fd & Inf.Name)
            Pcnt = Pcnt + 1
            Midasi(Pcnt) = Wb.Name
            With Wb.Worksheets(1)
                Set rr = .Range("C5").CurrentRegion
                Base = rr.Offset(1).Resize(rr.Rows.Count - 1, rr.Columns.Count)
            End With
            For i = 1 To UBound(Base, 1)
                If Base(i, 1) <> "" Then
                    If Not D.Exists(Base(i, 1)) Then
                        ReDim Retu(1 To Fs.GetFolder(Fd).Files.Count)
                        Retu(Pcnt) = Base(i, 2)
                        D.Add Base(i, 1), Retu
                    Else
                        Retu = D(Base(i, 1))
                        Retu(Pcnt) = Base(i, 2)
                        D(Base(i, 1)) = Retu
                    End If
                End If
            Next
            DoEvents
            Wb.Close False
            Set Wb = Nothing
            Erase Base
        Next
        y = 2
        .Cells(1) = "○計"
        .Cells(1, 2) = "趣　味"
        .Cells(1, 3).Resize(, UBound(Midasi)) = Midasi
        For i = 0 To D.Count - 1
            .Cells(y, 2) = D.Keys()(i)
            .Cells(y, 3).Resize(, UBound(Retu)) = D.Items()(i)
            .Cells(y, 1) = WorksheetFunction.CountA(.Cells(y, 3).Resize(, UBound(Retu)))
            y = y + 1
        Next
        .UsedRange.EntireColumn.AutoFit
    End With
    Set D = Nothing
    Set Inf = Nothing
    Set Fs = Nothing
End Sub
後処理追加　21:01
（隠居じーさん） 2019/07/22(月) 20:55

皆様、ありがとうございました。
書き換えたりして何とか完成させる事が出来ました！
感謝です。
（VBA勉強中） 2019/07/23(火) 19:11

コメント返信：

[ 一覧(最新更新順) ]

[[20190721131304]] 『フォルダ内にある全ファイルの特定セルの転記方法』（VBA勉強中） ページの最後に飛ぶ

[[20190721131304]]　『フォルダ内にある全ファイルの特定セルの転記方法』（VBA勉強中）　ページの最後に飛ぶ