[[20161113005946]]　『VBAで複数シートから条件の合ったものだけを別シ＝x（ねこよん）　ページの最後に飛ぶ

『VBAで複数シートから条件の合ったものだけを別シートに集計したいです』（ねこよん）

色々と試してみましたがうまくいきません。お知恵をお借りできますでしょうか。
集計シートに複数データシートから条件に合った列の数字を合計したいのです。

データ表
H6からU6の列にランダムに日付が入ります（月は入らず1日なら1と入力）
行は1847行
各シートのH6からU6に入る日付は規則性はなく同じ日が何個もある場合もあります。
このデータシートが65シートあります。

集計表
H6から右へ31列目まで1から31の日付を入れています。
この日付の列に、各データ表の日付が合致する列の1847行それぞれを合計させたいです。

例えば、各データ表シート（65シート）の例えば1と入力しているH6からU6の列の1847行を集計表の1の列に合計したいのです。
シートによっては1が無いものもあります。

説明が分かりにくくてすみません。
浅い知識で色々と試行錯誤しましたがうまくいきませんでした。
どうぞよろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 これを関数一発というリスエストでしょうね。
 専門家さんから、いずれ、回答があるでしょうけど、βはできないので面倒かもしれませんがエクセル機能併用。

 ・空白の作業シートを用意します。
 ・その H6 を選択して、データタブの統合。
 ・領域を以下にして実行
　　集計シートのH6:AL6
　　各シートの　H6:U1847
 ・作業シートの H6:AL187を選択して並び替え、オプションで列方向。並び替えのキーを　行6

 これで、作業シートに1日から31日までの数値が列挙されますので、あとは集計シートの7行目に、作業シートの該当列の 7行目から下の値を
 合計する SUM をいれる。

（β） 2016/11/13(日) 09:40

『VBAで…

ということみたいです。シート数も多いので気持ちはわかります。

（マナ） 2016/11/13(日) 09:53

 あっ！　【VBAで】でしたか。

 以下、一例です。

 作業シートは不要。　集計シート以外はすべて各データシートだという前提。
 １８４７というのが　７行目から１８４７行目までなのか、７行目から１８４７行なのか（つまり１８５３行目まで）不明だったので
 前者にしています。違っていれば ★ のところを変更してください。

 Sub Sample()
    Dim w(1 To 31)
    Dim shT As Worksheet
    Dim shF As Worksheet
    Dim c As Range

    Set shT = Sheets("集計")
    For Each shF In Worksheets
        If shF.Name <> shT.Name Then
            For Each c In shF.Range("H6:U6")
                If Not IsEmpty(c) Then
                    w(c.Value) = w(c.Value) + WorksheetFunction.Sum(c.Offset(1).Resize(1841))   '★
                End If
            Next
        End If
    Next

    shT.Range("H7:AL7").Value = w

 End Sub

（β） 2016/11/13(日) 09:55

コメントありがとうございます！
コードを試してみました。
それぞれの日付に集計されてはいるのですが、7行目に合計されてしまいます。
G列に商品コードの列があり1847行それぞれの行にそれぞれ合計されるにはどうすればよいのでしょうか？

聞いてばかりですみません。
（ねこよん） 2016/11/13(日) 11:41

 >>それぞれの日付に集計されてはいるのですが、7行目に合計されてしまいます。

 はい、そうしていますから。

 レイアウト確認です。

 集計表には　6行目の日付とは別に G列に商品コードが記載されている（G7:G1847)
 各データシートもG列に商品コードが記載されている。（G7:G1847)

 各データシートの数値を　集計表のマトリックスの該当の場所に合計するということですね。

 その理解でコードを書いてアップしますので、違っていれば早めにいってくださいね。

（β） 2016/11/13(日) 12:49

そういことならば、統合を使いましょう。

 Option Explicit

 Sub test()
    Dim s()
    Dim ws As Worksheet
    Dim n As Long

    With Worksheets("集計")
        For Each ws In Worksheets
            If ws.Name <> .Name Then
                ReDim Preserve s(n)
                s(n) = ws.Range("G6:U6").Resize(1841).Address(True, True, xlR1C1, True)
                n = n + 1
            End If
        Next

        .Range("G6:AL6").Resize(1841).Consolidate _
                Sources:=s, _
                Function:=xlSum, _
                TopRow:=True, _
                LeftColumn:=True

    End With

 End Sub

（マナ） 2016/11/13(日) 12:57

 マナさん回答の統合がいいと思いますけど、無理やり（？）別案です。

 Sub Sample2()
    Dim dic As Object
    Dim v As Variant
    Dim x As Long
    Dim c As Range
    Dim com As Range
    Dim d As Variant
    Dim shT As Worksheet
    Dim shF As Worksheet

    Set shT = Sheets("集計")
    Set dic = CreateObject("Scripting.Dictionary")

    For Each c In shT.Range("G7", shT.Range("G" & Rows.Count).End(xlUp))
        x = x + 1
        dic(c.Value) = x
    Next

    ReDim v(1 To dic.Count, 1 To 31)

    For Each shF In Worksheets
        If shF.Name <> shT.Name Then
            For Each com In shF.Range("G7:G1847")
                If dic.exists(com.Value) Then   '念のため
                    For Each c In com.EntireRow.Columns("H:U")
                        d = c.EntireColumn.Cells(6).Value   '日付
                        Select Case d
                            Case 1 To 31    '念のため
                                v(dic(com.Value), d) = v(dic(com.Value), d) + c.Value
                        End Select
                    Next
                End If
            Next
        End If
    Next

    shT.Range("H7").Resize(UBound(v, 1), UBound(v, 2)).Value = v

 End Sub

（β） 2016/11/13(日) 13:56

βさん、マナさん　本当にありがとうございます！
教えていただいたコードで試したところ、マナさんから教えていただいたコードは数字が集計シートに入ってきませんでした。
βさんから教えていただいたコードではインデックスが有効範囲でないとのデバックが出ました。

ここまでお力お借りできたのに心苦しのですが、お時間があれば引き続き見ていただけたら嬉しいです。
やりたい事の内容はβさんがコメントに書いていただいたことに間違いありません。

本当にありがとうございます。
助かります。
（ねこよん） 2016/11/13(日) 15:02

 >>インデックスが有効範囲でないとのデバックが出ました

 アップしたコードで、それがでるとしたら、集計シートの商品コードに重複があったとしか考えられないのですが・・

 そういったこともあった場合にもエラーにならないように手当てをすると以下になります。
 エラーになるかどうか試していただけますか。もし、これでもエラーになれば、エラーになったコードを教えてください。

 Sub Sample3()
    Dim dic As Object
    Dim v As Variant
    Dim x As Long
    Dim c As Range
    Dim com As Range
    Dim d As Variant
    Dim shT As Worksheet
    Dim shF As Worksheet

    Set shT = Sheets("集計")
    Set dic = CreateObject("Scripting.Dictionary")

    With shT.Range("G7", shT.Range("G" & Rows.Count).End(xlUp))
        ReDim v(1 To .Rows.Count, 1 To 31)
        For Each c In .Cells
            x = x + 1
            dic(c.Value) = x
        Next
    End With

    For Each shF In Worksheets
        If shF.Name <> shT.Name Then
            For Each com In shF.Range("G7:G1847")
                If dic.exists(com.Value) Then   '念のため
                    For Each c In com.EntireRow.Columns("H:U")
                        d = c.EntireColumn.Cells(6).Value   '日付
                        Select Case d
                            Case 1 To 31    '念のため
                                v(dic(com.Value), d) = v(dic(com.Value), d) + c.Value
                        End Select
                    Next
                End If
            Next
        End If
    Next

    shT.Range("H7").Resize(UBound(v, 1), UBound(v, 2)).Value = v

 End Sub

（β） 2016/11/13(日) 15:28

 ちなみに、こちらで用意したテストブックでマナさんのコードを実行すると、ちゃんと値がセットされます。
 仮に、G列商品に重複があっても、マナさんのコードではエラーにならず、それぞれ、同じ値がセットされます。
 （私がアップしなおしたコードでは、重複があった場合には、下のほうの商品行に転記されます）

 転記されないということは、我々のレイアウト解釈と、そちらの実態が違うということですけど？

（β） 2016/11/13(日) 16:19

βさん！マナさん！時間取っていただいてありがとうございました！
こちらのレイアウト、商品コード重複などがありました。
申し訳ないです。
こんな風に出来たらなって言う内容が完璧に実行されてました。
お2人とも本当にありがとうございました。
すごいです！
（ねこよん） 2016/11/13(日) 17:04

コメント返信：

[ 一覧(最新更新順) ]

[[20161113005946]] 『VBAで複数シートから条件の合ったものだけを別シ＝x（ねこよん） ページの最後に飛ぶ

[[20161113005946]]　『VBAで複数シートから条件の合ったものだけを別シ＝x（ねこよん）　ページの最後に飛ぶ