Автор: SAS888
Дата сообщения: 20.09.2011 10:23
Попробуйте [more=этот]
Код: Sub Main()
Dim i As Long, j As Long, k As Long, bi As Long, ci As Long, temp As String
Dim x As New Collection, y As New Collection, a(), b(), c()
Dim r As Long, r1 As Long, r2 As Long, col As Long, blok As Integer
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Application.ScreenUpdating = False: Application.DisplayAlerts = False
On Error Resume Next: Sheets("Уникальные").Delete: On Error GoTo 0
Set ws = ActiveSheet: Sheets.Add.Name = "Уникальные": Set ws1 = ActiveSheet
Workbooks.Add xlWBATWorksheet: ActiveSheet.Name = "Повторы": Set ws2 = ActiveSheet
col = ws.UsedRange.Columns.Count: r = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
ws.Range(ws.[A1], ws.Cells(1, col)).EntireColumn.Copy
ws1.[A1].PasteSpecial Paste:=xlPasteColumnWidths
ws2.[A1].PasteSpecial Paste:=xlPasteColumnWidths
ws.Activate
a = Range("E1:H" & r).Value
For i = 1 To UBound(a, 1)
temp = a(i, 1) & a(i, 2) & a(i, 3) & a(i, 4)
On Error Resume Next: x.Add temp, temp
If Err <> 0 Then
y.Add temp, temp: On Error GoTo 0
End If
Next
blok = Application.RoundUp(r / 30000, 0): r1 = 1: r2 = 30000
For k = 1 To blok
If r2 > r Then r2 = r
a = Range(Cells(r1, 1), Cells(r2, col)).Value
bi = 0: ci = 0: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)): c = b
For i = 1 To UBound(a, 1)
temp = a(i, 5) & a(i, 6) & a(i, 7) & a(i, 8)
On Error Resume Next: y.Add temp, temp
If Err = 0 Then
bi = bi + 1
For j = 1 To UBound(a, 2): b(bi, j) = a(i, j): Next
Else
ci = ci + 1
For j = 1 To UBound(a, 2): c(ci, j) = a(i, j): Next
On Error GoTo 0
End If
Next
If bi > 0 Then ws1.Cells(ws1.UsedRange.Rows.Count + 1, 1).Resize(bi, col).Value = b
If ci > 0 Then ws2.Cells(ws2.UsedRange.Rows.Count + 1, 1).Resize(ci, col).Value = c
r1 = r2 + 1: r2 = r2 + 30000
Next
[A1].Select: Set x = Nothing: Set y = Nothing: ws1.Activate
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub
