20170503xlVBA房地产数据分类连接
2024-09-12 02:53:10
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
最新文章
- navicate怎么用sql语句插入一条语句
- SQL SERVER 2014 Agent服务异常停止案例
- Linux驱动学习步骤(转载)
- java 集合(set)
- BZOJ 1486 最小圈
- 如何创建ajax对象?
- LightOJ 1038-Race to 1 Again(概率dp)
- SQLite数据库如何存储和读取二进制数据
- AFNetWorking源码详解(二)
- java.io.serializable
- 图像的影像地图超链接,<;map>;标签浅谈
- 【IOS】在SDK中打开其他接入应用的解决方案
- F4IF_FIELD_VALUE_REQUEST 和 F4IF_INT_TABLE_VALUE_REQUEST的不同
- 【Mac上的PotPlayer视频播放器】Movist Pro for Mac 2.1.2
- 20175312 2018-2019-2 《Java程序设计》第9周学习总结
- 微信h5支付源码DEMO参考
- radio样式的写法,单选和多选如何快速的改变默认样式,纯CSS,
- Anaconda 虚拟环境安装及应用
- MAC安装python jupyter notebook
- Python distribute到底使用package_data还是MANIFEST.in?