Typo generator in Excel

As the number of generated typos can be quite large, the proposition below is for original words inserted in first row of the sheet (not in column A - use copy and paste special with transpose).
I used just 4 types of typos - missing letter, Czech mistake (error in sequence of two neighbours), random replacement of one letter and random inserton of one letter. Of course one can use many more of them.
See the working model in attachment, and the code below:

Sub typogenerator()
Dim i As Long, j As Integer, l As Integer, k As Long, proper As String
Dim typos() As String
Application.ScreenUpdating = False
ReDim typos(1 To 1)
For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
  k = 1
  proper = Cells(1, i)
'missed one letter
  For j = 1 To Len(proper)
    ReDim Preserve typos(1 To k)
    typos(k) = Left(proper, j - 1) & Mid(proper, j + 1)
    k = k + 1
  Next j
'Czech mistake
  For j = 1 To Len(proper) - 1
    ReDim Preserve typos(1 To k)
    typos(k) = Left(proper, IIf(j > 1, j - 1, 0)) & Mid(proper, j + 1, 1) & Mid(proper, j, 1) & Mid(proper, j + 2)
    k = k + 1
  Next j
'any character replaced with random one
  For j = 1 To Len(proper)
    For l = 97 To 122 ' you may wish to try also 32 To 126
      ReDim Preserve typos(1 To k)
      typos(k) = Left(proper, j - 1) & Chr(l) & Mid(proper, j + 1)
      k = k + 1
    Next l
  Next j
'random char inserted on any position between original
  For j = 1 To Len(proper) + 1
    For l = 97 To 122 ' you may wish to try also 32 To 126
      ReDim Preserve typos(1 To k)
      typos(k) = Left(proper, j - 1) & Chr(l) & Mid(proper, j)
      k = k + 1
    Next l
  Next j
'add next typos here similar way if you need

'write horizontal array in vertical way into a sheet
  Cells(2, i).Resize(k - 1, 1).Value = Application.Transpose(typos)
'remove duplicates, because inserting _a_ into Adam can leed to Ad_a_am and Ada_a_m etc.
  Cells(1, i).Resize(k, 1).RemoveDuplicates Columns:=1, Header:=xlNo
Next i
End Sub

Just for the sake of completeness. The following code, transposes the data and writes it straight into a CSV file.

Sub WriteFile()

  Dim ColNum As Integer
  Dim Line As String
  Dim LineValues() As Variant
  Dim OutputFileNum As Integer
  Dim PathName As String
  Dim RowNum As Integer
  Dim SheetValues() As Variant

  PathName = Application.ActiveWorkbook.Path
  OutputFileNum = FreeFile

  Open PathName & "\Test.csv" For Output Lock Write As #OutputFileNum

  'Print #OutputFileNum, "Field1" & "," & "Field2"

  SheetValues = Sheets("RawData").Range("A1:C249").Value

Dim RowMax
RowMax = UBound(SheetValues)
Dim ColMax
ColMax = 3
ReDim LineValues(1 To RowMax)

  For ColNum = 1 To ColMax
    For RowNum = 1 To RowMax
      LineValues(RowNum) = SheetValues(RowNum, ColNum)
    Next
    Line = Join(LineValues, ",")
    Print #OutputFileNum, Line
  Next

  Close OutputFileNum

End Sub

Dear Kaper,

That's excellent. This is what I was looking for. Just to let you know, I was looking to build a typo dictionary to feed a SOLR deployment. Which is why I needed it in rows which could be saved as a CSV. This eases a lot of pain at my end. Really appreciate it.

CP