|
- Sub lqxs()
- Dim Arr, i&, r1, n&, d, k
- Dim Sht As Worksheet
- Set d = CreateObject("Scripting.Dictionary")
- Sheet1.Activate
- [a16].Resize(500, 17).ClearContents
- n = 16
- For Each Sht In Sheets
- If Sht.Name <> Sheet1.Name Then
- Arr = Sht.UsedRange
- Set r1 = Sht.[k:k].Find(0, , , 1)
- If Not r1 Is Nothing Then
- If r1.Row <> 1 Then
- If Arr(r1.Row, 13) = 0 Then
- d(r1.Row) = ""
- For i = r1.Row - 1 To 1 Step -1
- If Arr(r1.Row, 7) = Arr(i, 7) Then
- d(i) = ""
- Else
- Exit For
- End If
- Next
- If d.Count > 1 Then
- k = d.keys
- For i = UBound(k) To 0 Step -1
- n = n + 1
- Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, k(i), 0)
- Next
- n = n + 1
- End If
- End If
- End If
- End If
- End If
- d.RemoveAll
- Next
- End Sub
复制代码 |
评分
-
查看全部评分
|