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