Macro To Create Sheet with Consecutive Letter Strings

[Toby123]

Hello!

I am looking for a sheet with consecutive 6 letter strings, using all the letters of the alphabet except a, e, i, o, u, x and z. It would start with bbbbbb, bbbbbc, bbbbbd, then when it reaches bbbbbz jump to bbbbcb, bbbbcc, bbbbcd etc. It should end at yyyyyy. This should give 47,045,881 (19^6) combinations by my reckoning. If it is easier we could run it with all the letters then search and remove the cells containing the unwanted letters afterwards. I presume a macro would be the best way of doing this. Thank you in advance!

 

[BigBeachBananas]

What is your desired layout on the sheet? It obviously exceeds the row limits of excel.

 

[Toby123]

What is your desired layout on the sheet? It obviously exceeds the row limits of excel.

Thanks, 50k rows would be fine with results running vertically from A1 then continuing from B1 when it hits the bottom.

 

[ranman256]

paste code into a module, then run: AutoWordMake

Public Const kLTRS = "bcdfghijklmnpqrstvwy"
Public Const kiLEN = 6
Public Const kiLastRow = 1048576
'Public Const kiLastRow = 32000

Sub AutoWordMake()
Dim c1, c2, c3, c4, c5, c6
Dim a1, a2, a3, a4, a5, a6
Dim iMax As Integer
Dim lCol As Long

iMax = Len(kLTRS)
Range("A1").Select


For c1 = 1 To iMax
    a1 = getLtr(c1)
    For c2 = 1 To iMax
       a2 = getLtr(c2)
        For c3 = 1 To iMax
          a3 = getLtr(c3)
            For c4 = 1 To iMax
               a4 = getLtr(c4)
                For c5 = 1 To iMax
                   a5 = getLtr(c5)
                    For c6 = 1 To iMax
                        a6 = getLtr(c6)
                        
                        ActiveCell.Value = a1 & a2 & a3 & a4 & a5 & a6
                        If ActiveCell.Row = kiLastRow Then
                           NextCol
                           lCol = ActiveCell.Column
                           Cells(1, lCol).Select
                        Else
                           NextRow
                        End If
                    Next
                Next
            Next
        Next
    Next
Next
MsgBox "Done"
End Sub

Private Sub NextRow()
ActiveCell.Offset(1, 0).Select
End Sub

Private Sub NextCol()
ActiveCell.Offset(0, 1).Select
End Sub


Private Function getLtr(ByVal pvVal)
getLtr = Mid(kLTRS, pvVal, 1)
End Function

 

[Toby123]

paste code into a module, then run: AutoWordMake

Public Const kLTRS = "bcdfghijklmnpqrstvwy"
Public Const kiLEN = 6
Public Const kiLastRow = 1048576
'Public Const kiLastRow = 32000

Sub AutoWordMake()
Dim c1, c2, c3, c4, c5, c6
Dim a1, a2, a3, a4, a5, a6
Dim iMax As Integer
Dim lCol As Long

iMax = Len(kLTRS)
Range("A1").Select


For c1 = 1 To iMax
    a1 = getLtr(c1)
    For c2 = 1 To iMax
       a2 = getLtr(c2)
        For c3 = 1 To iMax
          a3 = getLtr(c3)
            For c4 = 1 To iMax
               a4 = getLtr(c4)
                For c5 = 1 To iMax
                   a5 = getLtr(c5)
                    For c6 = 1 To iMax
                        a6 = getLtr(c6)
                       
                        ActiveCell.Value = a1 & a2 & a3 & a4 & a5 & a6
                        If ActiveCell.Row = kiLastRow Then
                           NextCol
                           lCol = ActiveCell.Column
                           Cells(1, lCol).Select
                        Else
                           NextRow
                        End If
                    Next
                Next
            Next
        Next
    Next
Next
MsgBox "Done"
End Sub

Private Sub NextRow()
ActiveCell.Offset(1, 0).Select
End Sub

Private Sub NextCol()
ActiveCell.Offset(0, 1).Select
End Sub


Private Function getLtr(ByVal pvVal)
getLtr = Mid(kLTRS, pvVal, 1)
End Function

Thank you so much! It is currently running, it has been going for a couple of hours now.

 

[ranman256]

its a LOT of letters

 

[Toby123]

its a LOT of letters

Ha! Yes it is. I had the code running for 14 hours and had no results. Have you had it working at your end?

 

[Fluff]

How about

Sub Toby()
   Dim Ary(1 To 50000, 1 To 1) As Variant, Lts As Variant
   Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
   Dim nr As Long, nc As Long
  
   Lts = Split("b,c,d,f,g,h,j,k,l,m,n,p,q,r,s,t,v,w,y", ",")
   nc = 1
   Application.ScreenUpdating = False
   For i = 0 To 18
      For j = 0 To 18
         For k = 0 To 18
            For l = 0 To 18
               For m = 0 To 18
                  For n = 0 To 18
                     nr = nr + 1
                     Ary(nr, 1) = Lts(i) & Lts(j) & Lts(k) & Lts(l) & Lts(m) & Lts(n)
                     If nr = 50000 Then
                        Cells(1, nc).Resize(50000).Value = Ary
                        nc = nc + 1
                        nr = 0
                     End If
                  Next n
               Next m
            Next l
         Next k
      Next j
   Next i
   Cells(1, nc).Resize(nr).Value = Ary
End Sub

 

[Joe4]

Ha! Yes it is. I had the code running for 14 hours and had no results. Have you had it working at your end?

I am not surprised. You REALLY want to avoid using "ActiveCell" and "Select" statements within loops, especially if they are large.
It is inefficient and will absolutely kill your performance.
Most of the time, it is not necessary to select the cells to work with them. You can simply loop through them, like Fluff's shows in his code.

 

[Toby123]

Amazing, thank you so much everyone! I will give it a whirl.