Formula for pasting parts of a cell into another cell

[HarrySiers]

Dear forumers,

I am searching for a way to do the following:

A1 contains the following words:

Red Yellow Blue Magenta Green Black White Grey Pink Brown

I am looking for a formula that does the following:

Place in cells A1 through A55 the following words: Red Yellow Blue Magenta Green Black White Grey Pink Brown

AND

Place in cells B1 through B55 the following words in the order displayed below:

Red Yellow Blue Magenta Green Black White Grey Pink Brown
Red Yellow Blue Magenta Green Black White Grey Pink
Red Yellow Blue Magenta Green Black White Grey
Red Yellow Blue Magenta Green Black White
Red Yellow Blue Magenta Green Black
Red Yellow Blue Magenta Green
Red Yellow Blue Magenta
Red Yellow Blue
Red Yellow
Red
Yellow Blue Magenta Green Black White Grey Pink Brown
Yellow Blue Magenta Green Black White Grey Pink
Yellow Blue Magenta Green Black White Grey
Yellow Blue Magenta Green Black White
Yellow Blue Magenta Green Black
Yellow Blue Magenta Green
Yellow Blue Magenta
Yellow Blue
Yellow
Blue Magenta Green Black White Grey Pink Brown
Blue Magenta Green Black White Grey Pink
Blue Magenta Green Black White Grey
Blue Magenta Green Black White
Blue Magenta Green Black
Blue Magenta Green
Blue Magenta
Blue
Magenta Green Black White Grey Pink Brown
Magenta Green Black White Grey Pink
Magenta Green Black White Grey
Magenta Green Black White
Magenta Green Black
Magenta Green
Magenta
Green Black White Grey Pink Brown
Green Black White Grey Pink
Green Black White Grey
Green Black White
Green Black
Green
Black White Grey Pink Brown
Black White Grey Pink
Black White Grey
Black White
Black
White Grey Pink Brown
White Grey Pink
White Grey
White
Grey Pink Brown
Grey Pink
Grey
Pink Brown
Pink
Brown

Finally, it would be great if the formula would be easily adaptable, in such a way that it also works if another colour will be added to the colours in A1, for instance Red Yellow Blue Magenta Green Black White Grey Pink Brown Orange

 

[RickXL]

Hi,

I think this is going to easier using a macro.

Just go into the VB Editor, insert a new Module (Insert-->Module) and paste in the code below.

Hit F5 when in the editor to run the macro or you can add a button to the worksheet to run it too.

I have assumed that the sheet name will be Sheet1 but you can change that by overtyping.
The macro remembers the contents of A1 then clears columns A and B before starting.
Finally, it AutoFits the columns.

Sub colList()

    Dim ws As Worksheet
    Dim strList As String
    Dim arrList As Variant
    Dim iRow As Long
    Dim Delim As String
    Dim lngWrdMax As Long
    Dim i As Long, j As Long, k As Long
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    With ws
        strList = .Range("A1").Value
        .Columns("A:B").Clear
        .Range("A1").Value = strList
        
        arrList = Split(strList, " ")
        lngWrdMax = UBound(arrList)
        
        iRow = 1
        For i = 0 To lngWrdMax
            For j = 0 To lngWrdMax - i - 1
                Delim = ""
                strList = ""
                For k = i To lngWrdMax - j - 1
                    strList = strList & Delim & arrList(k)
                    Delim = " "
                Next
                .Cells(iRow, 1).Value = .Range("A1").Value
                .Cells(iRow, 2).Value = strList
                iRow = iRow + 1
            Next
        Next

        .Columns("A:B").AutoFit
    End With
    
    Application.ScreenUpdating = True
    
End Sub

 

[HarrySiers]

Hi,

I think this is going to easier using a macro.

Just go into the VB Editor, insert a new Module (Insert-->Module) and paste in the code below.

Hit F5 when in the editor to run the macro or you can add a button to the worksheet to run it too.

I have assumed that the sheet name will be Sheet1 but you can change that by overtyping.
The macro remembers the contents of A1 then clears columns A and B before starting.
Finally, it AutoFits the columns.

Sub colList()

    Dim ws As Worksheet
    Dim strList As String
    Dim arrList As Variant
    Dim iRow As Long
    Dim Delim As String
    Dim lngWrdMax As Long
    Dim i As Long, j As Long, k As Long
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    With ws
        strList = .Range("A1").Value
        .Columns("A:B").Clear
        .Range("A1").Value = strList
        
        arrList = Split(strList, " ")
        lngWrdMax = UBound(arrList)
        
        iRow = 1
        For i = 0 To lngWrdMax
            For j = 0 To lngWrdMax - i - 1
                Delim = ""
                strList = ""
                For k = i To lngWrdMax - j - 1
                    strList = strList & Delim & arrList(k)
                    Delim = " "
                Next
                .Cells(iRow, 1).Value = .Range("A1").Value
                .Cells(iRow, 2).Value = strList
                iRow = iRow + 1
            Next
        Next

        .Columns("A:B").AutoFit
    End With
    
    Application.ScreenUpdating = True
    
End Sub

Hi, RickXL,

Thank you very much! I am new to this forum, and impressed there are wizzkids that offer a solution so fast. I will try it out and let you know. Impressive! Harry

 

[RickXL]

Hi,

The trick to getting a reply is to be clear about what you expect and not expecting the world.

When you see two questions and one you can see exactly what is required and another which has several problems that the asker clearly has not thought about, which one do spend your spare time trying to help?

Anyway, let me know how it works out.
(Many don't even do that.)

Regards,

 

[HarrySiers]

Hi,

The trick to getting a reply is to be clear about what you expect and not expecting the world.

When you see two questions and one you can see exactly what is required and another which has several problems that the asker clearly has not thought about, which one do spend your spare time trying to help?

Anyway, let me know how it works out.
(Many don't even do that.)

Regards,

Hello RickXL, it works fine, to me you're a wizard. Thank you very much again!

 

[RickXL]

Hi,

If you want that process to be extendable then it is necessary only to remember the extra input strings then add another loop outside the existing ones:

Sub colList()

    Dim ws As Worksheet
    Dim strList As String
    Dim arrList As Variant
    Dim arrIn As Variant
    Dim iStr As Long
    Dim lr As Long
    Dim iRow As Long
    Dim Delim As String
    Dim lngWrdMax As Long
    Dim i As Long, j As Long, k As Long
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    With ws
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        arrIn = .Range("A1:A" & lr).Value
        Columns("A:B").Clear
        
        iRow = 1
        For iStr = 1 To UBound(arrIn)
            arrList = Split(arrIn(iStr, 1), " ")
            lngWrdMax = UBound(arrList)
            
            For i = 0 To lngWrdMax
                For j = 0 To lngWrdMax - i - 1
                    Delim = ""
                    strList = ""
                    For k = i To lngWrdMax - j - 1
                        strList = strList & Delim & arrList(k)
                        Delim = " "
                    Next
                    .Cells(iRow, 1).Value = arrIn(iStr, 1)
                    .Cells(iRow, 2).Value = strList
                    iRow = iRow + 1
                Next
            Next
        Next
        .Columns("A:B").AutoFit
    End With
    
    Application.ScreenUpdating = True
    
End Sub