Option Explicit
Private mvarSource As Variant
Private mlngNew As Long
Private mlngDeleted As Long
Private Enum dupHeaders
dpYEs = 1
dpNo = 2
End Enum
Sub archiefinventaris_Knop1_Klikken()
'Versie 2
Application.ScreenUpdating = False
Sheets("archiefinventaris").Unprotect Password:=Sheets("archiefdagrapportage").Range("i2")
RemoveDuplicates Source:=Range("C1:O" & ActiveSheet.UsedRange.Rows.Count), _
Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), _
Header:=dpNo
Range("C1").Select
Sheets("archiefinventaris").Protect Password:=Sheets("archiefdagrapportage").Range("i2")
Application.ScreenUpdating = True
End Sub
Private Sub RemoveDuplicates(ByVal Source As Range, _
ByRef Columns As Variant, _
ByVal Header As dupHeaders)
'Source is een range variabele
'Columns doet niets momenteel
'header is een constante van enum dupheaders(zie bovenin module)
Dim mVarNew As Variant
If Source.Cells.Count = 1 Then
MsgBox "deze bewerking kan niet worden uitgevoerd op één enkele cel", _
vbInformation
Exit Sub
ElseIf Source.Areas.Count <> 1 Then
MsgBox "Selecteer een bereik en niet gehele kolommen!", _
vbInformation
Exit Sub
ElseIf Source.Rows.Count > 50000 Then
MsgBox "Selecteer een bereik en niet gehele kolommen!", _
vbInformation
Exit Sub
End If
Application.ScreenUpdating = False
XLSort Source, Header
Application.ScreenUpdating = True
mVarNew = StripDuplicates(Source, Header)
Sheets.Add
ActiveSheet.Range("A1").Resize(UBound(mVarNew, 2), UBound(mVarNew, 1)) = _
XL_Transpose(mVarNew)
MsgBox "Er zijn " & mlngDeleted & " rijen verwijderd, en er blijven " & _
mlngNew & " Unieke waarden over.", vbInformation
End Sub
Private Function StripDuplicates(ByVal rngDuplicates As Range, _
ByVal Header As dupHeaders) As Variant
Dim avarDuplicates As Variant
Dim avarClean As Variant
Dim i As Long
Dim j As Long
Dim strRow As String
Dim strCompare As String
mlngDeleted = 0
mlngNew = 0
avarDuplicates = rngDuplicates.Value
ReDim avarClean(1 To UBound(avarDuplicates, 2), 1)
For i = LBound(avarDuplicates) + (Header Mod 2) To UBound(avarDuplicates)
strRow = Join(WorksheetFunction.Index(avarDuplicates, i, 0), "")
If StrComp(strCompare, strRow, vbBinaryCompare) = 0 Then
'skip this row
mlngDeleted = mlngDeleted + 1
Else
'new unique row, add it.
mlngNew = mlngNew + 1
ReDim Preserve avarClean(1 To UBound(avarDuplicates, 2), 1 To mlngNew)
For j = 1 To UBound(avarDuplicates, 2)
avarClean(j, mlngNew) = avarDuplicates(i, j)
Next
End If
strCompare = strRow
Next
StripDuplicates = avarClean
End Function
Private Sub XLSort(ByVal RangeToSort As Range, _
ByVal Headers As dupHeaders)
'Supports more than 3 columns
Dim i As Long
Dim lngLast As Long
With RangeToSort
For i = .Columns.Count To 1 Step -2
If i >= 3 Then
.Sort Key1:=.Cells(1, i - 2), Order1:=xlAscending, _
Key2:=.Cells(1, i - 1), Order2:=xlAscending, _
Key3:=.Cells(1, i), Order3:=xlAscending, _
Header:=Headers
ElseIf .Columns.Count = 2 Then
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
Key2:=.Cells(1, 2), Order2:=xlAscending, _
Header:=Headers
ElseIf .Columns.Count = 1 Then
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
Header:=Headers
Else
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
Key2:=.Cells(1, 2), Order2:=xlAscending, _
Key3:=.Cells(1, 3), Order3:=xlAscending, _
Header:=Headers
End If
Next
End With
End Sub
Private Function XL_Transpose(ByVal avarMatrix As Variant) As Variant
Dim avarResult As Variant
Dim i As Long
Dim j As Long
If IsArray(avarMatrix) Then
ReDim avarResult(1 To UBound(avarMatrix, 2), 1 To UBound(avarMatrix, 1))
For i = LBound(avarMatrix, 2) To UBound(avarMatrix, 2)
For j = LBound(avarMatrix, 1) To UBound(avarMatrix, 1)
avarResult(i, j) = avarMatrix(j, i)
Next
Next
XL_Transpose = avarResult
Else
XL_Transpose = avarMatrix
End If
End Function
