------ [Module1] -------
'DictionaryƒIƒuƒWƒFƒNƒg(˜A‘z”z—ñ) ‚ð—˜—p‚µ‚½�WŒv

Sub Soukei()
  '”z—ñ’è‹`
  Dim g, tle
  Dim clm As Integer
  Dim rws As Integer
  With Worksheets("Sheet1").Cells(1)
    With .CurrentRegion
      rws = .Rows.Count     '—á‚Å‚Í(19)
      clm = .Columns.Count  '�@�@�@( 5)
      tle = .Resize(, clm)
      With .Resize(rws - 1, clm).Offset(1)
        g = .Value    '“ñŽŸŒ³”z—ñ g(1, 1)�`g(18, 5)
      End With
    End With
  End With
  
  Dim Ur, Uc As Integer
  Ur = UBound(g, 1)   '“ñŽŸŒ³”z—ñ‚̈ꎟ�Å‘å“Y�”(18)
  Uc = UBound(g, 2)   '“ñŽŸŒ³”z—ñ‚Ì“ñŽŸ�Å‘å“Y�”( 5)
  
  '˜A‘z”z—ñ (Dictionary ƒIƒuƒWƒFƒNƒg) ’è‹`
  Dim Dic As Object
  Set Dic = CreateObject("Scripting.Dictionary")
  
  Dim Mkys As String     'ƒL�[’è‹`
  Dim Itms() As String   '’l‚Ì’è‹`
    
  For i = 1 To Ur
    If Not IsEmpty(g(i, 2)) Then
      Mkys = Left(CStr(g(i, 2)), 1) _
             & " " & CStr(g(i, 3))    'ƒL�[�Ý’è
      ReDim Itms(1 To Uc) As String
                  
      Select Case Dic.Exists(Mkys)    '“o˜^”»’è
        Case 0   '‹U (–¢“o˜^)
          For j = 1 To Uc
            Itms(j) = CStr(g(i, j))   '’l�Ý’è
          Next j
          
          Select Case Left(Itms(2), 1)
            Case Is = "A"
              Itms(1) = "�”‚` " & Itms(3)
            Case Is = "B"
              Itms(1) = "�”‚a " & Itms(3)
            Case Is = "C"
              Itms(1) = "�”‚b " & Itms(3)
          End Select
          
          Dic.Add Mkys, Itms          '�V‹K“o˜^
          
        Case -1  '�^ (“o˜^�Ï)
          Itms = Dic.Item(Mkys)       '’l‚ð’Š�o
          Itms(4) = CStr(g(i, 4) _
                     + CInt(Itms(4))) '’†ŠÔ—Ý�Ï
          Itms(5) = CStr(g(i, 5) _
                     + CInt(Itms(5))) 'Šú––—Ý�Ï
          Dic.Item(Mkys) = Itms       'ƒL�[�Ä“o˜^
      End Select
    End If
  Next i
  
  'Sheet2 ‚É�WŒv•\Ž¦
  Dim syKey, syItm
  syKey = Dic.Keys    '“o˜^�σL�[
  syItm = Dic.Items   '“o˜^�Ï‚Ì’l
    
  With Worksheets("Sheet2")
    '‰æ–Ê‚Ì—}Ž~�Ý’è
    Application.ScreenUpdating = False
    With .Cells(1)
      .CurrentRegion.ClearContents    'ƒ^ƒCƒgƒ‹
      .Resize(, Uc).Value = tle
    End With
    
    For i = 0 To UBound(syKey)        '�WŒv•\Ž¦
      .Cells(i + 2, 1).Resize(, Uc) = syItm(i)
    Next i
    .Activate
    .Columns("A:A").AutoFit       'A—ñƒZƒ‹•�’²�®
    .Range("B:C").Delete          '•s—vƒZƒ‹�í�œ
    .Range("A1").Select
    '‰æ–Ê‚Ì—}Ž~‰ð�œ
    Application.ScreenUpdating = True
  End With
End Sub

                                                                   back top