[[20210912021517]]　『複数ブック：記号のカウントと値の合計』（とりにく）　ページの最後に飛ぶ

『複数ブック：記号のカウントと値の合計』（とりにく）

同一フォルダ内にある複数ブックの指定範囲に記載された内容のカウント・合計を自動で行いたく存じます。自分ではどうにもできませんでした。ご教示のほどよろしくお願いいたします。

＝＝
集計対象の各ブックの記載内容
A列：同じ英数字
B列：○ か -（記号）
C列：数字（整数）

↓↓集計↓↓　これを行いたいです。

集計先のブック（完成形）
A列：同じ英数字（そのまま）
B列：2行目以降の○ の個数
C列：2行目以降の数字の合計
＝＝

イメージは下記のようになります。
＝＝

     A      B     C　　[ブック1]
1   番号   記号   点数
2   z01    ○      3
3   z02    -      1
4   z03    -      1

     A      B     C　　[ブック2]
1   番号   記号   点数
2   z01    -      2
3   z02    -      2
4   z03    -      1

↓↓集計↓↓　これを行いたいです。

     A      B     C　　[集計(完成形)]
1   番号   記号   点数
2   z01    1      5
3   z02    0      3
4   z03    0      2
＝＝

どうぞよろしくお願いいたします。

＜使用アプリ：Excel2021(ver 16.52, for Mac)、使用 OS：macOS BigSur ＞

 データの統合（合計）で可能と思います。
https://allabout.co.jp/gm/gc/297748/

 記号の合計については、例えば各シートのD列に
 =IF(B2="〇",1,0)
 として、記号を数値化しておき、それも含めて集計してから、
 集計後のブックを整形すれば提示のレイアウトの様に出来ました。
（qwerty） 2021/09/12(日) 07:00

qwerty様
ありがとうございます。
記号を数値化する方法は考えつきませんでした。

集計するエクセルのブック数が100を超えるため，すべてを開いて統合（合計）するのは大変なので，VBAなどで一連の操作を自動化する方法をご教示いただけないでしょうか。自分では記述できませんでした。
ちなみに，A~C列の入力内容は150行程度あります。

お力添えのほどお願いできますでしょうか。

（とりにく） 2021/09/13(月) 10:18

 こんにちは　＾＾
多分。Ｍａｃでは連想配列が使えないとの、話を聞いたことがあります
本当かどうかmacないので解らないのですが、＾＾；
それと、100ファイル、操作　←　Winでも回答付きにくい傾向に(*'▽')
あるかもしれません(T_T)
ちなみに、番号の一意な一覧表[番号マスタ]なるものは有りますでしょうか。
あと
VBAはHellowWorldをメッセージボックスで表示くらいなら、ご自分でおできに
なるのでせうか。
m(_ _)m

（隠居Ｚ） 2021/09/13(月) 13:38

Macで、フォルダ内のファイル一覧を取得する方法がわかりません。
GetOpenFilenameが使えるとよいのですが…
集計は「統合」機能を利用しています。

 １）作業用フォルダを用意
　２）その中に集計したいファイルを格納
　３）下記のマクロを実行
　４）ファイル選択ダイアログで、すべてのファイルを選択
　５）マクロブックの１番目のシートに結果を表示します

 Sub test()
    Dim ff, fn
    Dim tbl As Range, adr As String, s
    Dim wb As Workbook

    ff = Application.GetOpenFilename(MultiSelect:=True)
    If Not IsArray(ff) Then Exit Sub

    For Each fn In ff
        With Workbooks.Open(fn).Sheets(1)
            Set tbl = .Cells(1).CurrentRegion
            adr = adr & " " & tbl.Address(, , xlR1C1, True)
            tbl.Columns(2).Replace "-", ""
        End With
    Next

    s = Split(WorksheetFunction.Trim(adr))

    With ThisWorkbook.Sheets(1)
        .UsedRange.ClearContents
        .Cells(1).Consolidate s, xlSum, True, True
        .Cells(1).CurrentRegion.Resize(, 2).Consolidate s, xlCount, True, True
        .Cells(1).Value = "番号"
    End With

    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then wb.Close False
    Next

 End Sub

↑ただ100ファイルを同時に開くのは無謀かもしれません。
１つずつ開いて、閉じてを繰り返し
データを1つのシートに集約してから「統合」がよかったかも。
いずれにせよ、GetOpenFilenameでファイル一覧を取得できれば、
なんとかなると思います。

（マナ） 2021/09/13(月) 17:23

 Sub test2()
    Dim ff, fn
    Dim adr As String
    Dim wb As Workbook
    Dim ws As Worksheet

    ff = Application.GetOpenFilename(MultiSelect:=True)
    If Not IsArray(ff) Then Exit Sub

    Set ws = ThisWorkbook.Sheets(1)
    ws.UsedRange.ClearContents
    ws.Range("A1:C1").Value = Array("番号", "記号", "個数")

    For Each fn In ff
        Set wb = Workbooks.Open(fn)
        wb.Sheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
                ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         wb.Close False
    Next

    ws.Columns("B").Replace "-", ""
    adr = ws.Range("A1").CurrentRegion.Address(, , xlR1C1, True)
    ws.Range("E1").Consolidate adr, xlSum, True, True
    ws.Range("E1").CurrentRegion.Resize(, 2).Consolidate adr, xlCount, True, True
    ws.Range("E1").Value = "番号"
    ws.Columns("A:D").Delete

 End Sub

（マナ） 2021/09/13(月) 17:54

＞ Array("番号", "記号", "個数")

個数でなく、点数でした。

（マナ） 2021/09/13(月) 17:59

 こんばんは　＾＾
EXCEL2019では
Dir関数が改善され使えるとか。。。２０２１とのことなので
使えるかどうか、実験してもらうしかないような気が。
シェルからアップルスクリプト、なるものが使えるとか使えないとか＾＾；
私の場合、DIR関数が使えないと、ギブアップです。。。(T_T)
(￣▽￣)
済みませんでした。
m(_ _)m
（隠居Ｚ） 2021/09/13(月) 19:41

隠居Z 様

こんばんは！
こういった内容だと回答つきにく傾向にあるのですね。
ご回答いただいている皆様，ありがとうございます。

番号マスタのような一覧表はなく，A列は全ブック同じで，z001~z125までの英数字が上から順に並んでいます。
VBAに関しては初心者ですが，メーセージボックスでHellow Worldを表示させることはできます。

自分のエクセルでもDir関数は使えました。

何かよい方法などあればご教示いただきたいです。
よろしくお願いします。
（とりにく） 2021/09/13(月) 20:09

マナ様

マクロを組んでいただきありがとうございます。
test2を試してみました。
ファイル選択画面は表示されるのですが，複数選択はできませんでした。
また，ファイルを1つだけ選択して開こうとしても開けませんでした。
Macの仕様のせいなのでしょうか。

申し訳がありませんが，他に対処法・やり方などありましたらご教示いただけますでしょうか。
よろしくお願いします。
（とりにく） 2021/09/13(月) 20:15

MultiSelect:=True　が無視されてしまうのであれば
お手上げです。

（マナ） 2021/09/13(月) 21:19

 こんばんは　＾＾
↓とりあえず、実験お願いいたします。まともに、テスト用ダミーブックが
作成、削除等、出来れば、なんとかなるかも。。。←多分ですが。。。＾＾；
ハングアップのリスクを伴いますので、実験実行はアプリの強制終了のご準備
を整えてからにしてくださいませ。
新規作成の任意のフォルダに新規ブックでお試しを。m(_ _)m
Sub zDummyBookMK()
    Dim fD As String
    Dim fNm As String
    Dim wB As Workbook
    Dim i As Long
    Dim cnt As Long
    Dim v() As Variant
    Dim w()
    Dim t As Double
    t = Timer
    ReDim v(1 To 150, 1 To 1)
    Rnd -5
    fD = ThisWorkbook.Path & "/"
    fDelete
    Set wB = Workbooks.Add
    wB.SaveAs fD & "tmp.xlsx", 51
    For i = 1 To 150
        v(i, 1) = "z" & Format(i, "000")
    Next
    Do
        ReDim w(1 To 150, 1 To 3)
        For i = 1 To 150
            w(i, 1) = v(i, 1)
            If i Mod Int((5 - 1 + 1) * Rnd + 1) = 0 Then
                w(i, 2) = ChrW(9675)
            End If
            w(i, 3) = Int((5 - 1 + 1) * Rnd + 1)
        Next
        With wB.Worksheets(1)
            .UsedRange.Clear
            .Cells(1).Resize(, 3) = Array("番号", "記号", "点数")
            .Cells(2, 1).Resize(UBound(w, 1), UBound(w, 2)) = w
        End With
        wB.SaveCopyAs fD & "test" & Format(cnt, "000") & ".xlsx"
        cnt = cnt + 1
        If cnt Mod 16 = 0 Then DoEvents
        If cnt >= 3 Then Exit Do
    Loop
    wB.Close False
    If Dir(fD & "tmp.xlsx") <> "" Then
        Kill fD & "tmp.xlsx"
    End If

    Erase v, w
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Sub fDelete()
    Dim fNm As String
    Dim fD As String
    fD = ThisWorkbook.Path & "/"
    fNm = Dir(fD & "*.xlsx")
    Do Until fNm = ""
        Kill fD & fNm
        fNm = Dir()
    Loop
End Sub
（隠居Ｚ） 2021/09/13(月) 21:51

 追伸　＾＾；
マクロの有るブック
.xlsm
無いブック
.xlsx
ファイルの拡張子が違う場合は、実験を取り止め
お知らせください。
（隠居Ｚ） 2021/09/13(月) 21:56

 マナ　さん　のtest2実行して見ました
3ファイル位だと瞬間でした。。。(*'▽')
ｗ、統合も勉強してみます。m(_ _)m
（隠居Ｚ） 2021/09/13(月) 22:08

マナ様

同僚のWindowsを借りてtest2を実行したところ，瞬時にやりたかったことが完結しました。
調べたところ，MacではGetOpenFilenameは使えるもののMultiSelectは使えないようです。
Macの弊害が・・・

同僚のWindowsを使わせてもらえる時はこの方法を実行してみます。
大変ありがとうございました。
（とりにく） 2021/09/14(火) 00:32

隠居Z 様

何度もありがとうございます！
マナ様のtest2でwindowsでは実行できたのですが，自分はMacしかもっていないので，どうにかMacでもできるようになればいいなと思っています。

隠居Z様のものを試すと，「実行時エラー'75'　パス名/ファイル名が無効です。」と表示されました。
デバッグすると，Private Sub の Kill fD & fNm がハイライト表示されています。
ちなみに，マクロの有るブック（.xlsm）と無いブック（.xlsx）は括弧内のように拡張子が異なります。

自分でも Do と Loop でできないか試みましたが，やはり素人のためうまくできませんでした。
何か良い方法がありましたらご教示のほどお願いいたします。
（とりにく） 2021/09/14(火) 00:42

 おはようございます　＾＾
 fD = ThisWorkbook.Path & "/"

 を
       ↓

 fD = ThisWorkbook.Path & Application.PathSeparator

 に、変えてみて下さい。
今日は今から、外出です。夕刻には帰りますが
↑で動けば、他の方から、アドバイスが有るかもしれません。
多分動くと思います。。。＾＾；。。。多分。(￣▽￣)
m(_ _)m
（隠居Ｚ） 2021/09/14(火) 07:25

隠居Z 様

おはようございます。
変更してみましたが，「実行時エラー'75'」が出てしまいます。

自分で簡単なマクロを組み，同一フォルダ内にマクロブック(.xlsm)と集計元ブックの簡易版(.xlsx)を置いて実行した際には，
ThisWorkbook.Path & "/"
を使っていても動作しました。何か他に原因があるのでしょうか？

質問ばかりですみませんが，ご教示のほどよろしくお願いいたします。
（とりにく） 2021/09/14(火) 10:25

 こんばんわ。。。＾＾；
やはり、だめでしたか。。。
Msgbox fNm
で、中身を見ていただけますでしょうか。
fDも見て頂いて、合っているかご確認を。
空が返ると、何もせず終了するはずなので。何か返っている気がするのですが
フォルダ名、ファイル名、ともに、差支えなければ、教えて頂けますでしょうか。
不都合があれば結構ですが。命名規則に抵触していないか[使えない文字＾＾；]等
お調べを。。。m(_ _)m
dirがやはり不測の事態に有るのでしたら。LS　とか、調べてはみますが
私が解るかどうかは解りません。
 さらに、お詳しい方のアドバイスを、引き続きお待ちくださいませ。
（隠居Ｚ） 2021/09/14(火) 17:15

隠居Z 様

こんばんは。
ありがとうございます。

確認して以下が返されます。
fD：/Users/usersname/Desktop/集計test1/
fNm：book1.xlsx

試しに，
fD = ThisWorkbook.Path & Application.PathSeparator
を
fD = "/Users/usersname/Desktop/集計test1/"
に変更して実行したところ，なぜかこれまでのエラーは表示されなくなりましたが，
「実行時エラー ‘1004’:’　tmp.xlsx’ への変更は，共有違反のため保存されませんでした。別のファイルに保存し直して下さい。」
が表示されるようになりました。
これが解決できませんでした。

他にご有識者の方がおられましたら，ご教示のほどよろしくお願いいたします。
（とりにく） 2021/09/15(水) 02:51

 おはようございます　＾＾
Dir関数ですが、2019以降は使えるみたいですが、新規のフォルダでは先立って
アクセス権の設定が必要みたいです。↑はブックの共有で読み取り専用になっているか
若しくは何らかの理由でパーミッションが書込み禁止になっていることが原因の場合が
多いようです。後ろの、51消して見るのも一案ですが、多分関係無いかと。＾＾；
何れにしましても、私のコードはDir及びファイルの読み書き削除テストみたいなもの
なので、動かずとも、とりにく　さんの目的とはあまり関係は。。。ま、テストデーター
なので無関係とは言いませんが有っても無くても。。。m(__)m
Dirが動くなら、それでファイル一覧を作成され、マナさんのご提示のコードで目的は
達成されるのではないでしょうか。
読込だけで、保存は無かったように。。。←　多分＾＾；
でわでわ。また、m(_ _)m
（隠居Ｚ） 2021/09/15(水) 08:33

 追伸
最後の頼みの綱、 myPath = MacScript("ChooseFile")
MacScriptも廃止されているそぉで。。。ｍｍｍ
お役に立てず、済みませんでした。
わたしは、ここまでとさせて戴きます。m(__)m
撤収～～～(T_T)
m(__)mm(__)mm(__)m
（隠居Ｚ） 2021/09/15(水) 10:53

隠居Z 様

色々とご検討くださりありがとうございました。
アクセス権は付与しているのですが，ウィルス対策ソフトの問題かもしれません（ファイル監視停止してもうまくいきませんでしたが）。
自分でも検討してみます。
大変お世話になりました。ありがとうございました。

他にご有識者の方がおられましたら，ご教示のほどよろしくお願いいたします。
（とりにく） 2021/09/15(水) 15:48

DirがWindowsと同じように使えるなら

 Sub test3()
    Dim ws As Worksheet
    Dim p As String, fn As String
    Dim wb As Workbook
    Dim adr As String

    Set ws = ThisWorkbook.Sheets(1)
    ws.UsedRange.ClearContents
    ws.Range("A1:C1").Value = Array("番号", "記号", "個数")

    p = ThisWorkbook.Path & "\"     '★
    fn = Dir(p & "*.xlsx")

    Do While fn <> ""
        Set wb = Workbooks.Open(fn, ReadOnly:=True)
        wb.Sheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
                ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
         wb.Close False
         fn = Dir()
    Loop

    ws.Columns("B").Replace "-", ""
    adr = ws.Range("A1").CurrentRegion.Address(, , xlR1C1, True)
    ws.Range("E1").Consolidate adr, xlSum, True, True
    ws.Range("E1").CurrentRegion.Resize(, 2).Consolidate adr, xlCount, True, True
    ws.Range("E1").Value = "番号"
    ws.Columns("A:D").Delete

 End Sub

（マナ） 2021/09/15(水) 17:14

修正

 ＞Set wb = Workbooks.Open(fn, ReadOnly:=True)
     　　　 ↓
 　Set wb = Workbooks.Open(p & fn, ReadOnly:=True)

（マナ） 2021/09/15(水) 17:16

マナ様

ありがとうございます！やりたいことが実行できました！！

Macの仕様か，初めてアクセスする全てのフォルダ・ファイルにアクセス権を付与するウィンドウが立ち上がり，全てに許可を出すのは手間ですが。

大変お世話になりました。改めて御礼申し上げます。

（とりにく） 2021/09/16(木) 01:29

コメント返信：

[ 一覧(最新更新順) ]

[[20210912021517]] 『複数ブック：記号のカウントと値の合計』（とりにく） ページの最後に飛ぶ

[[20210912021517]]　『複数ブック：記号のカウントと値の合計』（とりにく）　ページの最後に飛ぶ