For Loop appending 6 diff strings to 6 consec cells then rep

[mawheele]

I have a rather tricky situation. I want to append 6 different strings to 6 consecutive cells in a column, then repeat throughout the entire range of the column. Basically, I want

316
316
316
316
316
316
317
317
317
317
317
317

To Become:

TOC_TOT_316
TOC_NEW_316
TOC_ADD_316
TOC_REPAIR_316
316
316
TOC_TOT_317
TOC_NEW_317
TOC_ADD_317
TOC_REPAIR_317
317
317

Right now, my loop looks like this:

With Myrange
        For x = 1 To 6
            Select Case x
                Case 1
                    Mystr = "TOC_TOT_"
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
                Case 2
                     Mystr = "TOC_NEW_"
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
                Case 3
                     Mystr = "TOC_ADD_"
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
                Case 4
                     Mystr = "TOC_REPAIR_"
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
                Case 5
                     Mystr = ""
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
                Case 6
                     Mystr = ""
                    .Offset(0, 1).Columns.Insert
                    .Offset(0, 1).FormulaR1C1 = "=Concatenate(""" & Mystr & """, RC[-1])"
                    .Columns(1).EntireColumn.Formula = .Columns(1).Offset(0, 1).EntireColumn.Value
                    .Columns(1).Offset(0, 1).EntireColumn.Delete
             End Select
            Next
 End With

I know its probably inefficient. Right now, its adding all those strings to every cell. Basically I need:

x = 1 To 6

to refer to the first 6 cells, and then repeat and do the next 6.

 

[Norie]

Why even loop?

Sub Concat()
Dim LastRow As Long

    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Range("B1").Formula = "=""TOC_TOT_""& A1"
    Range("B2").Formula = "=""TOC_NEW_""& A2"
    Range("B3").Formula = "=""TOC_ADD_""& A3"
    Range("B4").Formula = "=""TOC_REPAIR_""& A4"
    Range("B5:B6").Formula = "=A5"
    
    Range("B1:B6").Copy Range("B7").Resize(LastRow - 6)
    Columns("B:B").Copy
    Columns("B:B").PasteSpecial xlPasteValues
    Columns("A:A").Delete
    Application.CutCopyMode = False
    
End Sub

 

[Jonmo1]

Try this on for size

LR = Cells(Rows.Count, "A").End(xlUp).Row
For y = 0 To LR Step 6
    For x = 1 To 6
        If y + x > LR Then Exit Sub
        Select Case x
            Case 1
                Mystr = "TOC_TOT_"
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
            Case 2
                 Mystr = "TOC_NEW_"
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
            Case 3
                 Mystr = "TOC_ADD_"
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
            Case 4
                 Mystr = "TOC_REPAIR_"
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
            Case 5
                 Mystr = ""
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
            Case 6
                 Mystr = ""
                Cells(x + y, "A").Value = Mystr & Cells(x + y, "A").Value
         End Select
    Next x
Next y

 

[mawheele]

Code Works

Last one works brilliantly. Efficient too. Thanks!

 

[pgc01]

Hi mawheele

Here's another one:

Sub App()
Dim rRng As Range

Set rRng = Range("A1", Range("A" & Rows.Count).End(xlUp))
rRng.Value = Evaluate("CHOOSE(MOD(ROW(" & rRng.Address & ")-1,6)+1," & _
            """TOC_TOT_"",""TOC_NEW_"",""TOC_ADD_"",""TOC_REPAIR_"", """", """")&" & rRng.Address)
End Sub

Hope this helps
PGC