macro to copy specific columns of selected rows to another sheet

[acmehra]

Hi All ,

I am a beginner in vb. I want to copy data of rows selected by user to another sheet . But data from column A, B and E of the source sheet should be copied from the selected rows.

I am able to write the code which can copy whole row to destination sheet but I need help to copy data from specific columns only. Please help.

Below is my current code :

Sub btnS()
Selection.Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)Worksheets("destination").Activate
   End Sub

 

[Fluff]

Hi & welcome to the board
How about

Sub btnS()
   Union(Selection.Resize(, 2), Selection.Offset(, 4)).Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   Worksheets("destination").Activate
End Sub

 

[acmehra]

Hi & welcome to the board
How about

Sub btnS()
   Union(Selection.Resize(, 2), Selection.Offset(, 4)).Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   Worksheets("destination").Activate
End Sub

Its showing 1004 error. I Guess its because of

Union(Selection.Resize(, 2),

what should be the first parameter value in union ?

 

[Fluff]

What is the error message?

 

[JLGWhiz]

If you want to copy non contiguous columns and paste them as contiguous then

Dim rng As Range, c As Range
With ActiveSheet
    For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
        If c <> "" Then
            Set rng = Union(.Cells(c.Row, 1), .Cells(c.Row, 2), .Cells(c.Row, 5))
            rng.Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)
        End If
    Next
End With

Barring any typos, this would copy cells from columns A, B, E of a qualifying row and paste to the next available row of sheet 2.
This would copy and paste using the same columns in both sheets.

Dim rng As Variant, c As Range, i As Long
With ActiveSheet
    rng = Array(1, 2, 5)
    For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
        If c <> "" Then
            For i = LBound(rng) To UBound(rng)
                If i = LBound(rng) Then
                    .Cells(c.Row, rng(i)).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)
                Else
                    .Cells(c.Row, rng(i)).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(, i - 1)
                End If
            Next
        End If
    Next
End With

 

[Fluff]

Its showing 1004 error.

The code I supplied is based on the user selecting a single contiguous range in Col A

 

[acmehra]

Hi Fluff ,

Thank you for you inputs but user may or may not select contiguous rows on source sheet.

 

[Fluff]

In that case, how about

Sub btnS()
   
   Dim Rng As Range
   
   For Each Rng In Selection.Columns(1).Areas
      Union(Rng.Resize(, 2), Rng.Offset(, 4)).Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   Next Rng
   Worksheets("destination").Activate
End Sub

 

[acmehra]

In that case, how about

Sub btnS()
   
   Dim Rng As Range
   
   For Each Rng In Selection.Columns(1).Areas
      Union(Rng.Resize(, 2), Rng.Offset(, 4)).Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   Next Rng
   Worksheets("destination").Activate
End Sub

Its copying only first row out of all the selected rows

 

[Fluff]

Ok, try

Sub btnS()
   
   Dim Rng As Range
   
   For Each Rng In Selection.Areas
      Union(Rng.Resize(, 2), Rng.Resize(, 1).Offset(, 4)).Copy Sheets("destination").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
   Next Rng
   Worksheets("destination").Activate
End Sub