| 
    
     |  | ▼sakurako さん 今晩は。 
 Sheet1について
 機種をF列として作りました。
 A列のデータは日付形式のデータとします。
 
 結果の書き出しはSheet2にしています。
 
 Sheet1
 A       B     C      D        E       F
 date      tester  kind    proname     ownstr     機種
 2005/8/11 3:57  a1  LS_S  MTX1LP(A)_089    x30624fga    WHO
 2005/8/11 4:10  a2  LS_S  MTX1LP(A)_089    x30833fjd3   BMO
 2005/8/11 9:21  a3  LS_S  MTX1LP(A)_089    x30833fjd3   BMO
 2005/8/11 9:41  a4  LS_S  MTX1LP(A)_089    x30833fjd3   FMC
 2005/8/11 10:30  a5  LS_S  MTX1LP(A)_089    x30624fga    WHO
 2005/8/11 14:59  a6  LS_S  MTX1LP(A)_089    x30624fga    WHO
 2005/9/11 15:44  a7  LS_S  MTX1LP(A)_089    x30625fga    PLD
 2005/9/11 16:26  a8  LS_S  MTX1LP(A)_089    x30626fga    DIO
 
 Sheet2
 TOTAL 2005/08 2005/09
 WHO    3    3
 BMO    2    2
 FMC    1    1
 PLD    1        1
 DIO    1        1
 
 このような結果になります。
 
 試してみてください。
 
 Sub 集計()
 Dim sh1 As Worksheet
 Dim sh2 As Worksheet
 Dim dicA As Object, dicF As Object, dic集計 As Object
 Dim vnt, vntA, vntF
 Dim i As Long, j As Long
 Dim dd As String
 '
 Set sh1 = Sheets("Sheet1")
 Set sh2 = Sheets("Sheet2")
 '
 Set dicA = CreateObject("Scripting.Dictionary")
 Set dicF = CreateObject("Scripting.Dictionary")
 Set dic集計 = CreateObject("Scripting.Dictionary")
 
 vntA = sh1.Range("A2", sh1.Range("A65536").End(xlUp)).Value
 vntF = sh1.Range("F2", sh1.Range("F65536").End(xlUp)).Value
 '
 For i = 1 To UBound(vntA)
 dd = "'" & Format(vntA(i, 1), "yyyy/mm")
 dicA(dd) = Empty
 dicF(vntF(i, 1)) = dicF(vntF(i, 1)) + 1
 dic集計(dd & vntF(i, 1)) = dic集計(dd & vntF(i, 1)) + 1
 Next i
 '
 sh2.Cells.ClearContents
 sh2.Range("A2").Resize(dicF.Count).Value = Application.Transpose(dicF.keys())
 sh2.Range("B1").Value = "TOTAL"
 sh2.Range("C1").Resize(, dicA.Count).NumberFormatLocal = "@"
 sh2.Range("C1").Resize(, dicA.Count).Value = dicA.keys()
 '
 vnt = sh2.Range("A1").CurrentRegion.Value
 For i = 2 To UBound(vnt, 1)
 For j = 2 To UBound(vnt, 2)
 vnt(i, j) = dic集計("'" & vnt(1, j) & vnt(i, 1))
 Next
 Next i
 sh2.Range("A1").CurrentRegion.Value = vnt
 sh2.Range("B2").Resize(dicF.Count, 1).Value = Application.Transpose(dicF.items)
 sh2.Select
 '
 Set sh1 = Nothing
 Set sh2 = Nothing
 Set dicA = Nothing
 Set dicF = Nothing
 Set dic集計 = Nothing
 End Sub
 
 |  |