|
|
Sub 统计单位人数()
Application.ScreenUpdating = False
Dim ar As Variant
Dim rn As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim br()
ReDim br(1 To 10000, 1 To 3)
With Application.FileDialog(4)
If .Show Then folder_path = .SelectedItems(1)
End With
If folder_path = "" Then Exit Sub
f = Dir(folder_path & "\*.xls*") ' 文件名
Do While f <> "" ' 遍历文件夹中的所有文件
Set wb = Workbooks.Open(folder_path & "\" & f) ' 打开工作簿
With wb.Worksheets(1) '
r = .Cells(.Rows.count, 1).End(xlUp).Row
ar = .Range("a2:g" & r)
Set rn = .Rows(2).Find("单位", , , , , , 1)
End With
If rn Is Nothing Then MsgBox f & "文件内第二行没有单位字段，请核查后重试！": End
lh = rn.Column
wb.Close False
For i = 2 To UBound(ar)
If Trim(ar(i, lh)) <> "" Then
t = d(Trim(ar(i, lh)))
If t = "" Then
k = k + 1
d(Trim(ar(i, lh))) = k
t = k
br(k, 1) = k
br(k, 2) = ar(i, lh)
End If
br(t, 3) = br(t, 3) + 1
End If
Next i
Set rn = Nothing
f = Dir ' 读取下一个文件名
Loop
If k = "" Then MsgBox "没有需要条件的单位！": End
With Sheets(1)
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(k, 3) = br
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-11-13 09:13
楼主
