|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br(), arr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
ReDim arr(1 To 100000, 1 To 4)
For Each sht In Worksheets
dc(sht.Name) = ""
If sht.Index <= 3 Then
r = sht.Cells(Rows.Count, 1).End(xlUp).Row
ar = sht.Range("a1:e" & r)
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
n = n + 1
arr(n, 1) = ar(i, 1)
arr(n, 2) = ar(i, 4)
arr(n, 3) = ar(i, 3)
arr(n, 4) = ar(i, 2)
d(Trim(arr(n, 4))) = ""
End If
Next i
End If
Next sht
If n = "" Then MsgBox "数据源为空！": End
For Each k In d.keys
m = 0
ReDim br(1 To n, 1 To 3)
For i = 2 To n
If Trim(arr(i, 4)) = k Then
m = m + 1
For j = 1 To 3
br(m, j) = arr(i, j)
Next j
End If
Next i
If Not dc.exists(k) Then
Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
sh.Name = k
Else
Set sh = Sheets(k)
End If
With sh
.[a1].CurrentRegion.Borders.LineStyle = 0
.[a1].CurrentRegion = Empty
.[a1].Resize(1, 3) = Array("人员名称", "金额", "收账账号")
.[a2].Resize(m, UBound(br, 2)) = br
.Columns("a:c").AutoFit
.[a1].Resize(m + 1, UBound(br, 2)).Borders.LineStyle = 1
End With
Next k
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-5-18 09:06
楼主
