|
|
Sub 删除行()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
r = Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源区域为空！": End
ar = Range("a1:d" & r)
ReDim brr(1 To UBound(ar), 1 To UBound(ar, 2))
w = InputBox("需要保留几个？", "保留个数", "")
If w = "" Then End
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
s = ar(i, 1)
If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
d(s)(i) = ""
End If
Next i
On Error Resume Next
For Each k In d.keys
m = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
zd = ""
For Each kk In d(k).keys
m = m + 1
For j = 1 To UBound(ar, 2)
br(m, j) = ar(kk, j)
Next j
If ar(kk, 2) = "Parent" Then
If zd = "" Then
zd = m
Else
zd = zd & "|" & m
End If
End If
Next kk
If zd <> "" Then
rr = Split(zd, "|")
For i = 0 To Val(w) - 1
ks = "": js = ""
If i <= UBound(rr) Then
ks = rr(i)
js = rr(i + 1) - 1
If js = "" Then js = m
For s = ks To js
If s <= m Then
n = n + 1
For j = 1 To UBound(br, 2)
brr(n, j) = br(s, j)
Next j
End If
Next s
End If
Next i
Else
For i = 1 To Val(w)
n = n + 1
For j = 1 To UBound(br, 2)
brr(n, j) = br(i, j)
Next j
Next i
End If
Next k
[f1].CurrentRegion.Offset(1) = Empty
[f2].Resize(n, UBound(brr, 2)) = brr
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-22 22:46
楼主