How do I place remainder work in next column using this VB code? 2

[DrMingle]

I would like to expand this line of code:

If Len(InString) >= 8 Then

to a greater number lets say 9, but I would like to have column B continue the current process from column A. As you can imagine with anything over 8 I run out of rows, that is why I need to continue into the adjacent columns.

Below is the entire code:

Dim CurrentRow

Sub GetString()
    Dim InString As String
    InString = InputBox("Enter text to permute:")
    If Len(InString) < 2 Then Exit Sub
    If Len(InString) >= 8 Then
        MsgBox "Too many permutations!"
        Exit Sub
    Else
        ActiveSheet.Columns(1).Clear
        CurrentRow = 1
        Call GetPermutation("", InString)
    End If
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

 

[SkipVought]

Hi,

As you can imagine with anything over 8 I run out of rows, that is why I need to continue into the adjacent columns.

Quite to the contrary. I cannot possibly imagine when with "anything over 8" you would run out of rows. That makes absolutely no sense at all, in this context.

Please explain exactly what your problem is.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[DrMingle]

Here is my problem...

# of Characters Permutations
1 1
2 2
3 6
4 24
5 120
6 720
7 5,040
8 40,320
9 362,880
10 3,628,800
11 39,916,800
12 479,001,600

I would like to complete the permutation routine by empting the process in column B, C, D, etc... As it is now, when I hit the max rows in column A, I run out of rows.

 

[SkipVought]

So when CurrentRow exceeds the row limit, reset CurrentRow and add one to the column.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[PHV]

Or simply replace this:
Cells(CurrentRow, 1) = x & y
with this:
Cells(CurrentRow, 1 + CurrentRow \ 65000) = x & y

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[DrMingle]

Skip & PHV:

I apologize for the miscommunication. I looked back over Skips comments and realized that I supplied the wrong code...

I am still looking to find a way to complete this "subset" routine.

Let me know if you can help...(again).

Sub FindSubSets()
Application.ScreenUpdating = False
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim Target As String
Dim Output As String
Dim x As Long
Dim y As Long
Dim z As Long
If Selection.Rows.Count = 1 Or Selection.Columns.Count <> 1 Then
  MsgBox "Please select more than one row in a single column"
  Exit Sub
End If
a = ActiveCell.Row
b = ActiveCell.Column
c = Selection.Rows.Count + ActiveCell.Row - 1
d = 0
Target = InputBox("What is the address of the cell" & vbCrLf & "you want the numbers to add up to?")
Output = InputBox("What is the address of the first cell" & vbCrLf & "you want to output the results in?")
On Error GoTo Abort
Range(Output).Offset(d, 0) = ""
For x = a To c
  For y = x + 1 To c
  If Cells(x, b) + Cells(y, b) = Range(Target).Value Then
    Range(Output).Offset(d, 0) = Addr(x, b) + "+" + Addr(y, b)
    d = d + 1
  Else
    For z = y + 1 To c
    If Cells(x, b) + Cells(y, b) + Cells(z, b) = Range(Target).Value Then
      Range(Output).Offset(d, 0) = Addr(x, b) + "+" + Addr(y, b) + "+" + Addr(z, b)
      d = d + 1
    End If
    Next z
  End If
  Next y
Next x
Range(Output).Offset(d, 0) = ""
Abort:
Application.ScreenUpdating = False
End Sub
Private Function Addr(ByVal n As Integer, ByVal m As Integer) As String
  Addr = Cells(n, m).Address(False, False)
End Function

 

[SkipVought]

Please explain what is not working. Please be clear, concise and complete.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}