20170503xlVBA房地产数据分类连接

Sub NextSeven_CodeFrame4()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Const HEAD_ROW As Long = 2
    Const SHEET_NAME As String = "具体事项"
    Const START_COLUMN As String = "A"
    Const END_COLUMN As String = "I"

    Dim Key As String
    Dim OneKey

    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")

    Dim dInfo As Object
    Set dInfo = CreateObject("Scripting.Dictionary")

    Dim dCal As Object

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(SHEET_NAME)
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, "D").End(xlUp).Row
        Debug.Print EndRow
        Set Rng = .Range(.Cells(HEAD_ROW + 1, START_COLUMN), .Cells(EndRow, END_COLUMN))

        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            If Arr(i, 1) = "" Then Arr(i, 1) = Arr(i - 1, 1)
            Key = CStr(Arr(i, 5))
            Dic(Key) = Dic(Key) + 1

            Key = CStr(Arr(i, 5) & ";" & Arr(i, 1))
            dInfo(Key) = dInfo(Key) + 1

        Next i
    End With

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set oSht = Wb.Worksheets("协调合作单位分析")
    With oSht
        .UsedRange.Offset(HEAD_ROW).Clear
        N = 0
        dicsum = Application.WorksheetFunction.Sum(Dic.items)
        For Each ok In Dic.Keys    '合作单位是OK
            N = N + 1
            .Cells(N + HEAD_ROW, "A").Value = N
            .Cells(N + HEAD_ROW, "B").Value = ok
            .Cells(N + HEAD_ROW, "C").Value = Dic(ok)
            .Cells(N + HEAD_ROW, "D").Value = Format(Dic(ok) / dicsum, "#0.00%")

            Set dCal = CreateObject("Scripting.Dictionary")

            For Each pk In dInfo.Keys
                pos = InStr(1, pk, ok)
                If pos > 0 Then
                    pos = InStr(1, pk, ";")
                    nk = Mid(pk, pos + 1)    '区域
                    'Debug.Print nk
                    '区域及对应数量
                    dCal(nk) = dInfo(pk)
                End If
            Next pk

            iMax = Application.WorksheetFunction.Max(dCal.items)
            info = ""

            For x = iMax To 1 Step -1
                For Each nk In dCal.Keys    '区域
                    If dCal(nk) = x Then
                        info = info & nk
                        info = info & x
                        info = info & ";"
                    End If
                Next nk
            Next x
            .Cells(N + HEAD_ROW, "E").Value = Left(info, Len(info) - 1)
        Next ok
        Set Rng = .Range("A65536").End(xlUp).Offset(1)
        Rng.Resize(1, 2).Merge
        Rng.Value = "汇总"

        .Range("C65536").End(xlUp).Offset(1).Value = dicsum
        .Range("D65536").End(xlUp).Offset(1).Value = "100%"
             .Range("E:E").WrapText = True

             SetEdges .UsedRange
    End With

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    'MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio"

ErrorExit:
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    Set Dic = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub