Hallo Erik,
Het is geweldig, wat een speed.
Zou je hetzelfde -voetpad- willen betreden met dit fraais?
1e GetString
2e Test
Option Explicit
Dim CurrentRow
Sub GetString()
Dim InString As String
Dim n As Long
Range("B1") = ""
InString = InputBox("Voer 7 letters in,svp.")
If Len(InString) < 2 Then Exit Sub
If Len(InString) >= 8 Then
MsgBox "Teveel letters! Maximaal 7 letters."
Exit Sub
Else
ActiveSheet.Columns(1).Clear
CurrentRow = 1
Call GetPermutation("", InString)
End If
For n = 1 To 3
Call DubbelData
Next n
Range("B1").Formula = "=COUNTA(C[-1])"
End Sub
Sub GetPermutation(x As String, y As String)
Dim i As Integer, j As Integer
j = Len(y)
If j < 2 Then
Cells(CurrentRow, 1) = x & y
CurrentRow = CurrentRow + 1
Else
For i = 1 To j
Call GetPermutation(x + Mid(y, i, 1), _
Left(y, i - 1) + Right(y, j - i))
Next
End If
End Sub
Sub DubbelData()
Dim x As Long
Dim r As Range
Dim n As Long
Dim i As Integer
For i = 1 To 4
Range("A1:A5040").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
x = Cells(Rows.Count, "A").End(xlUp).Row
Set r = Range("A1:A" & x)
For n = 1 To x
If r.Cells(n, 1) = r.Cells(n + 1, 1) Then
r.Cells(n + 1, 1).ClearContents
End If
Next n
Range("A1:A5040").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
Next i
End Sub
Sub Test()
Dim rng As Range
Dim x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set rng = Range("A1:A" & Range("A65536").End(xlUp).Row)
For x = rng.Rows.Count To 1 Step -1
If Application.CheckSpelling(rng.Cells(x, 1).Value) = False Then
rng.Cells(x, 1).Delete Shift:=xlUp
End If
Next x
Set rng = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Bij mij duurde het 4 minuten en 40 seconden.