AndVGri
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Option Explicit
Private Keys As Collection
Private Function FirstEntry(ByVal Key As String, ByVal Index As Long) As Long
On Error GoTo errHandle
Keys.Add Index, Key
FirstEntry = -1
Exit Function
errHandle:
FirstEntry = Keys.Item(Key)
End Function
Public Sub test()
Dim LastCol As Long, i As Long, RowCount As Long
Dim heads() As String, id As Long
Dim key5, key6, key7, key8
Dim Status() As Long, wksSheet As Worksheet
Set Keys = New Collection
Set wksSheet = ActiveSheet
LastCol = wksSheet.UsedRange.Columns.Count + 1
Rows(1).Insert Shift:=xlDown
ReDim heads(1 To 1, 1 To LastCol)
For i = 1 To LastCol
heads(1, i) = "Cols" & CStr(i)
Next i
wksSheet.Range(wksSheet.Cells(1, 1), wksSheet.Cells(1, LastCol)).Value = heads
RowCount = wksSheet.UsedRange.Rows.Count
key5 = wksSheet.Range(wksSheet.Cells(2, 5), wksSheet.Cells(RowCount, 5)).Value
key6 = wksSheet.Range(wksSheet.Cells(2, 6), wksSheet.Cells(RowCount, 6)).Value
key7 = wksSheet.Range(wksSheet.Cells(2, 7), wksSheet.Cells(RowCount, 7)).Value
key8 = wksSheet.Range(wksSheet.Cells(2, 8), wksSheet.Cells(RowCount, 8)).Value
RowCount = RowCount
ReDim Status(1 To RowCount - 1, 1 To 1)
For i = 1 To RowCount - 1
id = FirstEntry(CStr(key5(i, 1)) & CStr(key6(i, 1)) & CStr(key7(i, 1)) & CStr(key8(i, 1)), i)
If id > 0 Then
Status(id, 1) = 1: Status(i, 1) = 1
Else
Status(i, 1) = 0
End If
Next i
If Keys.Count < (RowCount - 1) Then 'если есть хотя бы один дубль
wksSheet.Range(wksSheet.Cells(2, LastCol), wksSheet.Cells(RowCount, LastCol)).Value = Status
wksSheet.UsedRange.AutoFilter LastCol, "1"
wksSheet.Range(wksSheet.Cells(2, 1), wksSheet.Cells(RowCount, LastCol - 1)).Copy
ActiveWorkbook.Worksheets.Add
ActiveSheet.PasteSpecial XlPasteType.xlPasteColumnWidths
ActiveSheet.Paste
wksSheet.Range(wksSheet.Cells(2, 1), wksSheet.Cells(RowCount, LastCol - 1)).EntireRow.Delete Shift:=XlDeleteShiftDirection.xlShiftUp
wksSheet.UsedRange.AutoFilter
wksSheet.Columns(LastCol).Delete
wksSheet.Rows(1).Delete Shift:=XlDeleteShiftDirection.xlShiftUp
End If
End Sub
|
Всего записей: 750 | Зарегистр. 14-12-2005 | Отправлено: 04:32 20-09-2011 | Исправлено: AndVGri, 06:22 20-09-2011 |
|
