excel vba按内容排序

Sub s()
    For ctou = 1 To 4
    Dim d
    Set d = CreateObject("scripting.dictionary")
    For i = 12 To 130
        If Cells(1, i) <> "" Then
        a = Mid(Cells(1, i).Text, ctou, 1)
        If a = Mid(Cells(2, i).Text, ctou, 1) Then d(a) = d(a) + 1
        End If
    Next
    i = 12
    Do While d.Count
        b = 0
        For Each c In d.keys
            If d(c) > b Then
            a = c
            b = d(c)
            End If
        Next
        Cells(ctou * 2 + 1, i) = a
        Cells(ctou * 2 + 2, i) = b
        i = i + 1
        d.Remove (a)
    Loop
    Next
End Sub