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 |