How to copy Non-contiguous cells into a another sheet in VBA

[johnston]

I have a big table that from row 5 to row 4934, and goes from columns A to O. I created a macro to create a new worksheet with three columns to copy the data over from the other worksheet. Values from columns A,D,G,J and M in the original worksheet need to go in the first column of my new worksheet. The problem is that I need to the data to be copied row by row. For example, if cell A5=245 and cell D5=16, I would need 245 to be inserted first into my first column on my new worksheet and 16 right under it in the same column.

 

[alansidman]

I want to make sure I understand completely what you want.
1. Copy Cell values in columns A, D, G, J, and M in rows 5 through 4934.
2. Paste the values in Column A of the new sheet transposed. This would put the data in A1:A24645.
3. Please confirm that this is what you wish to happen or explain clearly if this is not what you want.

 

[johnston]

I want to make sure I understand completely what you want.
1. Copy Cell values in columns A, D, G, J, and M in rows 5 through 4934.
2. Paste the values in Column A of the new sheet transposed. This would put the data in A1:A24645.
3. Please confirm that this is what you wish to happen or explain clearly if this is not what you want.

Exactly

 

[Fluff]

How about

Sub CopyTrans()
   Dim Cl As Range, Ary
   For Each Cl In Sheets("[COLOR=#ff0000]Pcode[/COLOR]").Range("A5:A4934")
   Ary = Array(Cl.Value, Cl.Offset(, 3).Value, Cl.Offset(, 6).Value, Cl.Offset(, 9).Value, Cl.Offset(, 12).Value)
      Sheets("[COLOR=#ff0000]end[/COLOR]").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(5).Value = Application.Transpose(Ary)
   Next Cl
End Sub

Change sheet names in red to suit

 

[alansidman]

Maybe this loop

Option Explicit


Sub Johnston()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Dim lr As Long, i As Long, lr2 As Long
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = 5 To lr
        lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
        Application.Union(Range("A" & i), Range("D" & i), Range("G" & i), Range("J" & i), Range("M" & i)).Copy
        s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues, , , True
    Next i
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Action Completed"
End Sub

 

[johnston]

How about

Sub CopyTrans()
   Dim Cl As Range, Ary
   For Each Cl In Sheets("[COLOR=#ff0000]Pcode[/COLOR]").Range("A5:A4934")
   Ary = Array(Cl.Value, Cl.Offset(, 3).Value, Cl.Offset(, 6).Value, Cl.Offset(, 9).Value, Cl.Offset(, 12).Value)
      Sheets("[COLOR=#ff0000]end[/COLOR]").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(5).Value = Application.Transpose(Ary)
   Next Cl
End Sub

Change sheet names in red to suit

Works great. Would I just change the offset numbers to do this for the other two columns that I need?

 

[Fluff]

If you need further columns, then simply add them to the Ary and change the resize from 5 to however many columns you're copying.
However if I've got the wrong columns, then yes just change the offsets to suit.