求大神帮忙下这个怎么统计

zhangcheng6688

学习一下代码
Sub test()
arr = [k2].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 2)
For i = 2 To UBound(arr)
   If arr(i, 2) <> "" And InStr(arr(i, 1), "精神分裂症") Then
      m = m + 1
      brr(m, 1) = arr(i, 2)
      brr(m, 2) = 1
      For j = i + 1 To UBound(arr)
         If arr(j, 2) <> "" Then
            If arr(i, 2) = arr(j, 2) And InStr(arr(j, 1), "精神分裂症") Then
               brr(m, 2) = brr(m, 2) + 1
               arr(j, 2) = vbNullString
            End If
         End If
       Next
    End If
Next
[q2].Resize(m, 2) = brr
End Sub

zhangcheng6688

学习一下字典，打扰
Sub test()
lastr = Cells(Rows.Count, "l").End(xlUp).Row
arr = Range("k1:l" & lastr)
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
   If InStr(arr(i, 1), "精神分裂症") > 0 Then
      d(arr(i, 2)) = d(arr(i, 2)) + 1
   End If
Next
[n2].Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)
[o2].Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.items)
End Sub