Copying concatenated column and paste twice

Question

I have a macro which concatenate some cells together for me then pastes it into sheet 2 and 3. However I need it to repeat each cell twice

Sheet2 only needs from cell A2 to A14 and pasted into Sheet2 starting at J14

and Sheet3 needs everything from cell A15 till last row and pasted into Sheet3 starting at J8

my code doesn't seem to be working for my sheet3, but sheet1 is working decently

example: in my sheet 1 will be

  A   |   B  |  C
--------------------
Name1 | date | info
Name2 | date | info

after I concatenate everything I need it to look like

          A         |
--------------------
Name1 - date - info |
Name1 - date - info |
Name2 - date - info |
Name2 - date - info |

My current code:

Sub Concat()
Sheets("Sheet1").Select
Dim lRow As Long, i As Long
Dim rng As Range
Dim lr2 As Long

Set rng = Range("A16:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set rng2 = Range("A15:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Debug.Print rng.Address(External:=True)
lr2 = 1
lRow = rng.Row
For i = 2 To lRow

    ActiveWorkbook.Sheets("Sheet2").Cells(i + 12, 10) = Cells(i, 1) & " - " & Cells(i, 2) & " - " & Cells(i, 3) & " - " & Cells(i, 4)
  Next i

   lRow2 = rng2.Row
For i = 2 To lRow2
   ActiveWorkbook.Sheets("Sheet3").Cells(i + 6, 10) = Cells(i + 15, 1) & " - " & Cells(i + 15, 2) & " - " & Cells(i + 15, 3) & " - " & Cells(i + 15, 4)
  
  Next i
End Sub

I found a code which does repeat the column but I cant get to implement it into my code

    Sub copPas()


Dim s1 As Worksheet, s2 As Worksheet

Set s1 = Worksheets("Sheet1")
Set s2 = Worksheets("Sheet2")

Dim lr As Long, lr2 As Long
Dim i As Long


lr = s1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = 1

Application.ScreenUpdating = False

For i = 1 To lr
s2.Range("A" & lr2).Resize(2).Value = s1.Range("A" & i).Value
lr2 = lr2 + 2
Next i

Application.ScreenUpdating = True



End Sub

Another way **Logic**: **1.** Paste the data once **2.** Go to last row and paste it again **3.** Sort the data — Siddharth Rout, Nov 25 '20 at 07:47

score 2 · Accepted Answer · answered Nov 25 '20 at 07:15

Try this,

Sub concat()
  Dim shtSrc As Worksheet
  Dim shtDest1 As Worksheet
  Dim shtDest2 As Worksheet
  
  Dim lStartRow As Long: lStartRow = 2
  Dim lDest1SrcEndsAt As Long: lDest1SrcEndsAt = 14
  Dim lLastRow As Long
  Dim vData As Variant
  
  Dim aOutput() As String
  Dim lRepeats As Long: lRepeats = 2
  Dim lRows As Long
  Dim i As Long
  Dim j As Long
  
  With ThisWorkbook
    Set shtSrc = .Sheets("Sheet1")
    Set shtDest1 = .Sheets("Sheet2")
    Set shtDest2 = .Sheets("Sheet3")
  End With
  
  With shtSrc
    lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    If lLastRow < lStartRow Then lLastRow = lStartRow
    vData = .Range(.Range("A1"), .Range("C" & lLastRow)).Value2
  End With
  
  lRows = 0
  For i = lStartRow To lDest1SrcEndsAt
    lRows = lRows + lRepeats
    ReDim Preserve aOutput(1 To lRows)
    
    For j = 0 To lRepeats - 1
      aOutput(lRows - j) = vData(i, 1) & " - " & vData(i, 2) & " - " & vData(i, 3)
    Next j
  Next i
  With shtDest1.Range("J14")
    .Resize(Rows.Count - .Row).ClearContents
    .Resize(lRows, 1).Value2 = WorksheetFunction.Transpose(aOutput)
  End With
  
  lRows = 0
  For i = lDest1SrcEndsAt + 1 To lLastRow
    lRows = lRows + lRepeats
    ReDim Preserve aOutput(1 To lRows)
    
    For j = 0 To lRepeats - 1
      aOutput(lRows - j) = vData(i, 1) & " - " & vData(i, 2) & " - " & vData(i, 3)
    Next j
  Next i
  With shtDest2.Range("J8")
    .Resize(Rows.Count - .Row).ClearContents
    .Resize(lRows, 1).Value2 = WorksheetFunction.Transpose(aOutput)
  End With
End Sub

Working great! Thank you so much. Couldn't get my head around this — araau11, Nov 25 '20 at 08:12
Is there a way for the out of the concatenate to have max 50 char? — araau11, Nov 25 '20 at 08:30
@araau11 You're getting that error because you have merged cells. You can either unmerge those cells or remove this line completely. If you remove the line and the output rows are less than what had been previously generated, you will end up with some old data in one of the destination sheets (the second one actually as the first one gets a fixed number of rows every time). — Super Symmetry, Nov 25 '20 at 09:30
To limit the output to 50 chars you may want to append the line `aOutput(lRows - j) = Left(aOutput(lRows - j), 50)` to both inner `For j ...` loops — Super Symmetry, Nov 25 '20 at 09:32
Is there a fix for if Sheet1 only has rows less than 15 rows? it'll only fill sheet2 and skip sheet3? currently getting an error for the J loops if Sheet1 is less than 16 rows — araau11, Dec 08 '20 at 21:31

Siddharth Rout · Answer 2 · 2020-11-25T08:32:56.393

I have a macro which concatenate some cells together for me then pastes it into sheet 2 and 3. However I need it to repeat each cell twice

Another way which does not involve any loops.

Logic:

Use index(concatenate()) to concatenate all the data in one go without any loop. Explanation about index(concatenate())
Go to last row of the destination sheet and perform step 1 again
Sort the data

Code

Option Explicit

Dim wsThis As Worksheet
Dim wsThisLastRow As Long
Dim sAddr As String
Dim rngA As String, rngB As String, rngC As String

'~~> Delimiter
Const delim As String = """ - """

Sub Sample()
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    
    '~~> Source Sheet
    Set wsThis = Sheet1
    
    With wsThis
        wsThisLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        sAddr = "A1:A" & wsThisLastRow
    
        rngA = "'" & .Name & "'!A1:A" & wsThisLastRow
        rngB = "'" & .Name & "'!B1:B" & wsThisLastRow
        rngC = "'" & .Name & "'!C1:C" & wsThisLastRow
    End With
    
    Set wsA = Sheet2: Set wsB = Sheet3
    
    '~~> Generate Data twice in Sheet 2
    ConcatenateData wsA, 1, wsThisLastRow
    ConcatenateData wsA, wsThisLastRow + 1, 2 * wsThisLastRow
    
    '~~> Sort
    wsA.Columns(1).Sort Key1:=wsA.Range("A1"), _
                        Order1:=xlAscending, _
                        Header:=xlNo, _
                        OrderCustom:=1, _
                        MatchCase:=False, _
                        Orientation:=xlTopToBottom, _
                        DataOption1:=xlSortNormal

    
    '~~> Generate Data twice in Sheet 3
    ConcatenateData wsB, 1, wsThisLastRow
    ConcatenateData wsB, wsThisLastRow + 1, 2 * wsThisLastRow
    
    '~~> Sort
    wsB.Columns(1).Sort Key1:=wsB.Range("A1"), _
                        Order1:=xlAscending, _
                        Header:=xlNo, _
                        OrderCustom:=1, _
                        MatchCase:=False, _
                        Orientation:=xlTopToBottom, _
                        DataOption1:=xlSortNormal
End Sub

'~~> Conatenate the columns in 1 go
Private Sub ConcatenateData(ws As Worksheet, StartRow As Long, EndRow As Long)
    ws.Range("A" & StartRow & ":A" & EndRow).Value = _
    Evaluate("index(concatenate(" & rngA & "," & delim & "," & _
                                    rngB & "," & delim & "," & _
                                    rngC & "),)")
End Sub

In Action

Is there a way for the out of the concatenate to have max 50 char? – araau11 1 min ago

In such a case you can use index(Left(concatenate()))

'~~> Conatenate the columns in 1 go
Private Sub ConcatenateData(ws As Worksheet, StartRow As Long, EndRow As Long)
    ws.Range("A" & StartRow & ":A" & EndRow).Value = _
    Evaluate("index(Left(concatenate(" & rngA & "," & delim & "," & _
                                    rngB & "," & delim & "," & _
                                    rngC & "),50),)")
End Sub

I actually did think about this logic, but then I thought what if the OP wants to keep the same order in the source sheet :) — Super Symmetry, Nov 25 '20 at 09:26
I meant the "sort" logic. Just seen `index(concatenate())`: Very nice!! — Super Symmetry, Nov 25 '20 at 10:01

Copying concatenated column and paste twice

2 Answers2