[[20181012142612]]　『『重複データ複数条件の集計その2』』（seitomo）　ページの最後に飛ぶ

『『重複データ複数条件の集計その2』』（seitomo）

昨日、素晴らしいご回答をいただいた内容で、新たに追加したい項目が発生した為、再度質問させていただきます。

Sh1のA列に受付区分　B列に商品名　D列に店舗名　F列に個数　
といった表があります。
(1行目は空白で項目目はなく、2行目からデータが入っています)

 全ての項目の内容は、取込みデータで　毎回違います

Sh2の1行目は固定された項目が入っています

下記条件でSh2に集計結果をマクロを使って表示させたいです。　

条件1：Sh1のA列が「受注」もしくは「予約」
条件2：Sh1のB列＆D列の組み合わのもののF列の個数を合計する
条件3：条件1の範囲でSh1のB列＆D列の組み合わのものの個数をSh2のE列に表示

　
《Sh1》

    A   　B　　D　　　F
 1
 2  受注  あ　新宿　　5
 3　失注  あ　大阪　　2
 4　受注  い　新宿　　8
 5　予約  う　名古屋　2
 6　予約  あ　新宿　　1
 7　失注  い　福岡　　2
 8　受注  あ　大阪　　5
  ↓↓このように表示したいです
《Sh2》 
   A　　B　　　C　　E
 1
 2 あ   新宿　　6　2
 3 あ   大阪　　5　1
 4 い   新宿　　8　1
 5 う   名古屋　2　1

よろしくお願いいたします。

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

Sub main()

    Dim c As Range
    With Sheets("Sheet2")
        .Cells.ClearContents
        For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
            If c.Value = "受注" Or c.Value = "予約" Then
                .Range("A" & i + 2).Resize(, 3).Value = Array(c.Offset(, 1).Value, c.Offset(, 3).Value, c.Offset(, 5).Value)
                i = i + 1
            End If
        Next c
        For Each c In .Range("A:A").SpecialCells(2)
            c.Offset(, 3).Value = WorksheetFunction.SumIfs(.Range("C:C"), .Range("A:A"), c.Value, .Range("B:B"), c.Offset(, 1).Value)
            c.Offset(, 5).Value = WorksheetFunction.CountIfs(.Range("A:A"), c.Value, .Range("B:B"), c.Offset(, 1).Value)
        Next c
        .Range("C:C").Delete
        .Range("A2:E" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending
                .SetRange Range("A2:E" & Rows.Count)
                .Apply
            End With
    End With
End Sub
（mm） 2018/10/12(金) 14:55

私のコードを直すなら、元々、SUMIFS関数を使った数式を作成するコードにしていたので、追加列はCOUNTIFSで同じように作るだけです。ご自分で応用して欲しかったですね。

        .Range("C1:C" & AR.Count).Formula = "=SUMIFS('Sh1'!F1:F" & iMax & _
                                                   ",'Sh1'!A1:A" & iMax & ",""<>失注""," & _
                                                    "'Sh1'!B1:B" & iMax & ",A1," & _
                                                    "'Sh1'!D1:D" & iMax & ",B1)"
        .Range("E1:E" & AR.Count).Formula = "=COUNTIFS('Sh1'!A1:A" & iMax & ",""<>失注""," & _
                                                      "'Sh1'!B1:B" & iMax & ",A1," & _
                                                      "'Sh1'!D1:D" & iMax & ",B1)"
（???） 2018/10/12(金) 14:58

（mm）様　（???）様

早速ご教示いただき誠にありがとうございます。
無事解決に至りました。

この度挙げていただいた内容を熟考いたします。

重ね重ね御礼を申し上げます。
（seitomo） 2018/10/12(金) 15:05

あ、入力・出力共、2行目からに代わっているのですか。ならばもう少し変えて、以下で。

 Sub test()
    Dim AR As Object
    Dim vw As Variant
    Dim cw As String
    Dim i As Long
    Dim iMax As Long

    Set AR = CreateObject("System.Collections.ArrayList")
    With Sheets("Sh1")
        iMax = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To iMax
            If .Cells(i, "A").Text <> "失注" Then
                cw = .Cells(i, "B").Text & "|" & .Cells(i, "D").Text
                If Not AR.Contains(cw) Then
                    AR.Add cw
                End If
            End If
        Next i
    End With
    AR.Sort
    With Sheets("Sh2")
        .Cells.ClearContents
        For i = 0 To AR.Count - 1
            vw = Split(AR(i), "|")
            .Cells(i + 2, "A").Value = vw(0)
            .Cells(i + 2, "B").Value = vw(1)
        Next i
        .Range("C2:C" & AR.Count + 1).Formula = "=SUMIFS('Sh1'!F2:F" & iMax & _
                                                       ",'Sh1'!A2:A" & iMax & ",""<>失注""," & _
                                                        "'Sh1'!B2:B" & iMax & ",A2," & _
                                                        "'Sh1'!D2:D" & iMax & ",B2)"
        .Range("E2:E" & AR.Count + 1).Formula = "=COUNTIFS('Sh1'!A2:A" & iMax & ",""<>失注""," & _
                                                          "'Sh1'!B2:B" & iMax & ",A2," & _
                                                          "'Sh1'!D2:D" & iMax & ",B2)"
    End With
 End Sub
（???） 2018/10/12(金) 15:06

 別案

 Sub test()
     Dim cn As Object, rs As Object
     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 ThisWorkbook.FullName
     End With
     rs.Open "Select F2, F4, Sum(F6), Count(*) From `Sh1$A2:F50000` " & _
             "Where F1 In ('受注', '予約') Group By F2, F4", cn
     Sheets("sh2").Range("a2").CopyFromRecordset rs
     Set cn = Nothing: Set rs = Nothing
 End Sub
（seiya） 2018/10/12(金) 18:31
 参照列の修正 2018/10/13 20:45

コメント返信：

[ 一覧(最新更新順) ]

[[20181012142612]] 『『重複データ複数条件の集計 その2』』（seitomo） ページの最後に飛ぶ

[[20181012142612]]　『『重複データ複数条件の集計その2』』（seitomo）　ページの最後に飛ぶ