How to rearrange/create variations of text?

Hi there,

I need to create variations of text in Excel.

For e.g. in cell A1 I have the text: 'squeezy clear honey'. And I need to create variations of this text in column B.

I can create this manually by typing out all the variations.

For example:

squeezy honey clear
clear squeezy honey
clear honey squeezy
honey clear squeezy
honey squeezy clear

Is there a way to automatize this process instead of manually typing out the variations?

This will save me 10+ hours.

Many thanks

Based on the excellent code by PGC01 here:
http://www.mrexcel.com/forum/excel-q...mutations.html

I think this will take a list of words in A1 and give you all possible permutations:

Option Explicit
 
Sub PermutationsN_1ToP_R()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
 
vElements = Split(Range("A1"))
Columns(2).Clear
 
i = UBound(vElements)
    ReDim vresult(0 To UBound(vElements))
    Call PermutationsNPR(vElements, UBound(vElements), vresult, lRow, 0)
End Sub
 
Sub PermutationsNPR(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iIndex As Integer)
Dim i As Long, count, found_it As Boolean
 
For i = 0 To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("C" & lRow).Resize(, p + 1) = vresult
        found_it = False
        For count = 3 To Cells(lRow, Columns.count).End(xlToLeft).Column
            If WorksheetFunction.CountIf(Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)), Cells(lRow, count)) > 1 Then
                found_it = True
            End If
        Next
        If found_it = True Then
            Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
            lRow = lRow - 1
        Else
            Range("B" & lRow) = vresult(0)
            For count = 1 To UBound(vElements)
                Range("B" & lRow) = Range("B" & lRow) & " " & vresult(count)
            Next
            Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
        End If
SKIP_THIS_ONE:
    Else
        Call PermutationsNPR(vElements, p, vresult, lRow, iIndex + 1)
    End If
Next i
End Sub

Thank you Yudlugar! That works for one entry in A1.

But we have thousands of entries in column A.

E.g.
squeezy clear honey (A1)
red hot chilli peppers (A2)
large delicious ripe juicy apples (A3)
dried apricots (A4)

What do we do in order to create all of the permutations into column B?

Many thanks

You could build a loop like this...

Option Explicit

Sub PermutationsN_1ToP_R()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long, row_count As Integer
Columns(2).Clear
For row_count = 1 To Range("A" & Rows.count).End(xlUp).Row
    If Not Range("A" & row_count) = "" Then
        vElements = Split(Range("A" & row_count))
        i = UBound(vElements)
        ReDim vresult(0 To UBound(vElements))
        Call PermutationsNPR(vElements, UBound(vElements), vresult, lRow, 0)
    End If
Next
End Sub
 
Sub PermutationsNPR(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iIndex As Integer)
Dim i As Long, count, found_it As Boolean
lRow = Range("B" & Rows.count).End(xlUp).Row
For i = 0 To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("C" & lRow).Resize(, p + 1) = vresult
        found_it = False
        For count = 3 To Cells(lRow, Columns.count).End(xlToLeft).Column
            If WorksheetFunction.CountIf(Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)), Cells(lRow, count)) > 1 Then
                found_it = True
            End If
        Next
        If found_it = True Then
            Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
            lRow = lRow - 1
        Else
            Range("B" & lRow) = vresult(0)
            For count = 1 To UBound(vElements)
                Range("B" & lRow) = Range("B" & lRow) & " " & vresult(count)
            Next
            Range(Cells(lRow, 3), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
        End If
SKIP_THIS_ONE:
    Else
        Call PermutationsNPR(vElements, p, vresult, lRow, iIndex + 1)
    End If
Next i
End Sub

It might still take 10 hours though!

Thank you Yudlugar!

The loop works.

To be more specific there are two more columns which need to align with the results:

Here is the data we have (albeit thousands more rows):

Main Group	Sub Group	Keyword (without variation)
apples	red apples	apples red
apples	big green apples	big green apples
bananas	yellow bananas	yellow bananas
bananas	big riped yellow bananas	riped yellow bananas big

Here is what the results should look like:

Main Group	Sub Group	Keyword (with variations)
apples	red apples	red apples
apples	red apples	apples red
apples	big green apples	big green apples
apples	big green apples	big apples green
apples	big green apples	apples green big
apples	big green apples	apples big green
apples	big green apples	green apples big
apples	big green apples	green big apples
bananas	yellow bananas	yellow bananas
bananas	yellow bananas	bananas yellow
bananas	big riped yellow bananas	big riped yellow bananas
bananas	big riped yellow bananas	big riped bananas yellow
bananas	big riped yellow bananas	big yellow riped bananas
bananas	big riped yellow bananas	big yellow bananas riped
bananas	big riped yellow bananas	big bananas riped yellow
bananas	big riped yellow bananas	big bananas yellow riped
bananas	big riped yellow bananas	riped big yellow bananas
bananas	big riped yellow bananas	riped big bananas yellow
bananas	big riped yellow bananas	riped yellow big bananas
bananas	big riped yellow bananas	riped yellow bananas big
bananas	big riped yellow bananas	riped bananas big yellow
bananas	big riped yellow bananas	riped bananas yellow big
bananas	big riped yellow bananas	yellow big riped bananas
bananas	big riped yellow bananas	yellow big bananas riped
bananas	big riped yellow bananas	yellow riped big bananas
bananas	big riped yellow bananas	yellow riped bananas big
bananas	big riped yellow bananas	yellow bananas big riped
bananas	big riped yellow bananas	yellow bananas riped big
bananas	big riped yellow bananas	bananas big riped yellow
bananas	big riped yellow bananas	bananas big yellow riped
bananas	big riped yellow bananas	bananas riped big yellow
bananas	big riped yellow bananas	bananas riped yellow big
bananas	big riped yellow bananas	bananas yellow big riped
bananas	big riped yellow bananas	bananas yellow riped big

What do we do in order to create the second table?

Many thanks

Try the code below,

Note - a couple of tips that will help you get good a quick answers:
1. Rather than typing out a table into the post, make an example worksheet (click go advanced and then attachments to attach it to your post). This will make it much more likely that you will get a response as it saves people from typing out all your data. It also helps avoid problems due to data formatting
2. Describe the whole problem in the first post, rather than making a problem like the one you have and then expanding it, the best thing to do is to add a sheet in to your example workbook that gives an example of the solution that you want. I've edited the code I originally wrote to cope with the modifications but it may be that it would have been better to code it another way, had I known that was what things were like from the start!

Option Explicit
Sub PermutationsN_1ToP_R()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long, row_count As Integer
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ActiveSheet
Set ws2 = Sheets.Add
For row_count = 1 To ws1.Range("B" & Rows.count).End(xlUp).Row
    If Not ws1.Range("B" & row_count) = "" Then
        vElements = Split(ws1.Range("B" & row_count))
        i = UBound(vElements)
        ReDim vresult(0 To UBound(vElements))
        Call PermutationsNPR(ws1, ws2, vElements, UBound(vElements), vresult, lRow, 0, row_count)
    End If
Next
End Sub
 
Sub PermutationsNPR(ws1 As Worksheet, ws2 As Worksheet, vElements As Variant, p As Long, vresult As Variant, lRow As Long, iIndex As Integer, row_count As Integer)
Dim i As Long, count, found_it As Boolean
lRow = ws2.Range("C" & Rows.count).End(xlUp).Row
For i = 0 To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        ws2.Range("D" & lRow).Resize(, p + 1) = vresult
        found_it = False
        For count = 4 To ws2.Cells(lRow, Columns.count).End(xlToLeft).Column
            If WorksheetFunction.CountIf(ws2.Range(Cells(lRow, 4), ws2.Cells(lRow, ws2.Cells(lRow, Columns.count).End(xlToLeft).Column)), ws2.Cells(lRow, count)) > 1 Then
                found_it = True
            End If
        Next
        If found_it = True Then
            ws2.Range(ws2.Cells(lRow, 4), ws2.Cells(lRow, ws2.Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
            lRow = lRow - 1
        Else
            ws2.Range("A" & lRow) = ws1.Range("A" & row_count)
            ws2.Range("B" & lRow) = ws1.Range("B" & row_count)
            ws2.Range("C" & lRow) = vresult(0)
            For count = 1 To UBound(vElements)
                ws2.Range("C" & lRow) = ws2.Range("C" & lRow) & " " & vresult(count)
            Next
            Range(Cells(lRow, 4), Cells(lRow, Cells(lRow, Columns.count).End(xlToLeft).Column)).ClearContents
        End If
SKIP_THIS_ONE:
    Else
        Call PermutationsNPR(ws1, ws2, vElements, p, vresult, lRow, iIndex + 1, row_count)
    End If
Next i
End Sub

Thank you Yudlugar

You are a legend.

Thank you for the tips - I will bear that in mind next time I ask a question.

Thanks again