Ускорить работу программы

Dim razmer, schet As Integer
schet = 1
kolbukv = CInt(Text1.Text)
str = Text2.Text
razmer2 = Len(str)
ReDim sim(razmer2)
For i = 1 To Len(Text2)
   sim(i) = Mid$(Text2, i, 1)
  Next i
If kolbukv = 3 Then
 razmer = UBound(sim())
  For i1 = 1 To razmer
   For i2 = 1 To razmer
    For i3 = 1 To razmer
    slovo = sim(i1) & sim(i2) & sim(i3)
      If Application.CheckSpelling(slovo) Then
        Cells(schet, 1) = slovo
        schet = schet + 1
      End If
  Next i3
 Next i2
Next i1

Private Sub knop_Click()
Dim razmer2 As Long
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long
Dim i7 As Long
Dim i8 As Long
Dim i9 As Long
Dim i10 As Long
Dim i11 As Long
Dim i12 As Long
Dim kolbukv As Long
Dim sim() As String
Dim strok As String
Dim s As Boolean
Dim slovo As String
Dim razmer As Long
Dim schet As Long
schet = 1
kolbukv = CInt(Text1.Text)//количество букв в слове
strok = Text2.Text      //получаем набор букв из которых будет слово
razmer2 = Len(Text2)  //получаем количество букв введенных в Text2, для создания массива
ReDim sim(razmer2)    //создаем и даем массиву размер 
For i = 1 To Len(Text2)
   sim(i) = Mid$(Text2, i, 1)   // загоняем набор букв по отдельности в массив
  Next i
If kolbukv = 3 Then              // если в Тext1 введена цифра 3, значит в слове три буквы должно быть
 razmer = UBound(sim())     
  For i1 = 1 To razmer
   For i2 = 1 To razmer
    For i3 = 1 To razmer
    slovo = sim(i1) & sim(i2) & sim(i3)   // лепим из букв помещенных в массив, все варианты слов
    s = Application.CheckSpelling(slovo) // проверка слова, которая пропускает кучу слов((
    If (s) Then
    Cells(schet, 1) = slovo      //вывод в эксель
    schet = schet + 1
    End If
  Next i3
 Next i2
Next i1
ElseIf kolbukv = 4 Then

Option Explicit
Option Compare Text
Private Sub CommandButton1_Click()
    Dim dic, s As String, i As Long, j As Long, n As Long, k As Long
    Open ThisWorkbook.Path & "\Dictionary.txt" For Input As #1
          dic = Split(Input(LOF(1), #1), vbCrLf)
    Close #1
    n = Val(TextBox1.Text): s = Trim$(TextBox2.Text)
    ThisWorkbook.Sheets(1).Columns("B:B").ClearContents
    For i = 0 To UBound(dic)
       If Len(dic(i)) = n Then
         For j = 1 To Len(dic(i))
            If InStr(1, s, Mid(dic(i), j, 1)) = 0 Then GoTo m
         Next j
         k = k + 1
         Cells(k, 2) = dic(i)
m:     End If
    Next i
End Sub

Option Explicit
Option Compare Text
Sub Anagramma() '_CommandButton1_Click()
    Dim dic, S As String, i As Long, j As Long, n As Long, k As Long, q&, r&, sD$, Z$, sim$()
    'n = Val(TextBox1.Text): s = Trim$(TextBox2.Text)
    n = 5: S = "АРБУЗНЫЙ"
    ReDim sim(Len(S))
    ThisWorkbook.Sheets(1).Columns("B:B").ClearContents
    With Sheets("Slovo" & n) ' Ищем слова только на листе с нужным количеством букв
        dic = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    For i = 1 To Len(S)
        sim(i) = Mid$(S, i, 1)
    Next i
    For i = 1 To UBound(dic)
         Z = dic(i, 1)
         r = 0
         For j = 1 To Len(S)
            q = InStr(1, Z, sim(j))
            If q > 0 Then
                Z = Left(Z, q - 1) & Right(Z, Len(Z) - q)
                r = r + 1
                If r = n Then Exit For
            Else
                GoTo m
            End If
         Next j
         k = k + 1
         Cells(k, 2) = dic(i, 1)
m: Next i
End Sub

Option Explicit
Option Compare Text
Sub Anagramma() 'CommandButton1_Click()
    Dim dic, S$, i&, j&, n&, k&, q&, r&, LenS&, Z$, sim$()
    'n = Val(TextBox1.Text): s = Trim$(TextBox2.Text)
    S = [A5]
    n = [A7]
    LenS = Len(S)
    ReDim sim(LenS)
    ThisWorkbook.Sheets(1).Columns("B:B").ClearContents
    With Sheets("Slovo" & n) ' Ищем слова только на листе с нужным количеством букв
        dic = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    For i = 1 To LenS
        sim(i) = Mid$(S, i, 1)
    Next i
    For i = 1 To UBound(dic)
         Z = dic(i, 1)
         r = 0
         For j = 1 To LenS
            q = InStr(1, Z, sim(j))
            If q > 0 Then
                Z = Left(Z, q - 1) & Right(Z, Len(Z) - q)
                r = r + 1
                If r = n Then
                    k = k + 1
                    Cells(k, 2) = dic(i, 1)
                    Exit For
                End If
            ElseIf LenS - j < n - r Then
                Exit For
            End If
         Next j
    Next i
End Sub

Sub Anagramma()
    Dim i%, razmer%, kolbukv%, strok$, sim, sTemp, slovo$, schet&, vX, Dic As Object
    strok = [A5]
    razmer = [A7]
    kolbukv = Len(strok)
    ReDim sim(kolbukv)
    For i = 1 To kolbukv
        sim(i) = Mid$(strok, i, 1)
    Next i
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets(1).Columns("B:B").ClearContents
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    SlovoRecurs slovo, razmer, kolbukv, sim, Dic
    For Each vX In Dic.Keys
        schet = schet + 1
        Cells(schet, 2) = vX
    Next
End Sub
 
Sub SlovoRecurs(ByVal slovo$, razmer%, kolbukv%, sim, Dic As Object)
    Dim i%, sTemp, LenSlovo%, Slovo2$
    LenSlovo = Len(slovo)
    If LenSlovo >= razmer Then Exit Sub
    For i = 1 To kolbukv
        If sim(i) <> "" Then
            If LenSlovo = razmer - 1 Then
               If Application.CheckSpelling(slovo & sim(i), , False) Then
                   Dic(slovo & sim(i)) = 0&
               End If
            Else
                sTemp = sim
                Slovo2 = slovo & sim(i)
                sTemp(i) = ""
                SlovoRecurs Slovo2, razmer, kolbukv, sTemp, Dic
            End If
        End If
    Next i
End Sub