Copy and paste a list of names to different sheet and sort it

Question

Without using select or active, I’m trying to copy the names in two rows in Sheet1 and paste the names vertically in sheet2, and sort this new list.

So I wrote this code:

Sub CopyData()
  List1 = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
  List2 = Worksheets("Sheet1").Cells(36, Columns.Count).End(xlToLeft).Column

  Worksheets("Sheet1").Range("B2", Cells(2, List1)).copy
  Worksheets("Sheet2").Range("B3").PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False, Transpose:=True

  Worksheets("Sheet1").Range("B36", Cells(36, List2)).copy
  Worksheets("Sheet2").Cells(List1, 2).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=False, Transpose:=True

  Worksheets("Sheet2").Range("B2", Cells(List1 + List2, 2)).Sort Key1:=Range("B2"), Order1:=xlAscending, _
    Order2:=xlYes, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End sub

I use List1 and List2 variables to know how many names both rows have, so that I can combine them in to one in Sheet2.

The copy and paste part of the code alone works if I’m in Sheet1 and the sorting part of the code alone also works if I’m in Sheet2, however when I combine both codes it doesn’t work, so the problem must be that I need to reference the sheets or variables but I can’t seem to get this right, can someone help me.

Answer 1

Here's one way to copy the data on two different rows on one sheet, to a single column on another sheet. It should work no matter what sheet you are "on".

And, by the way, note that neither Select nor Activate is used.

Option Explicit
Sub CopyData()
  Dim WS1 As Worksheet, WS2 As Worksheet
  Dim rSortRange As Range
  Set WS1 = Worksheets("sheet1")
  Set WS2 = Worksheets("sheet2")
  WS2.Cells.Clear
    With WS1
        .Range("b2", .Cells(2, .Columns.Count).End(xlToLeft)).Copy
    End With
    WS2.Range("b3").PasteSpecial Paste:=xlPasteValues, skipblanks:=False, Transpose:=True

    With WS1
        .Range("b36", .Cells(36, .Columns.Count).End(xlToLeft)).Copy
    End With

    With WS2
        .Range("b3").End(xlDown).Offset(rowoffset:=1).PasteSpecial Paste:=xlPasteValues, skipblanks:=False, Transpose:=True
        Set rSortRange = .Range("B3", .Cells(Rows.Count, "B").End(xlUp))
        rSortRange.Sort key1:=rSortRange, order1:=xlAscending, Header:=xlNo
        .Range("b3").EntireColumn.AutoFit
    End With
    Application.CutCopyMode = False

End Sub

In case you wish to copy other rows, or more rows than just the two, here is a more generalized routine that allows you to enter multiple rows to copy/transpose/paste.

Also, since you are sorting, I chose to change the skipblanks parameter to True. The blanks will normall sort to the end anyway.

Option Explicit
Sub CopyData()
  Dim WS1 As Worksheet, WS2 As Worksheet
  Dim rDest As Range
  Dim rSortRange As Range
  Dim aRows As Variant
  Dim I As Long

  Set WS1 = Worksheets("sheet1")
  Set WS2 = Worksheets("sheet2")

Application.ScreenUpdating = False

  Set rDest = WS2.Range("B3")
  rDest.EntireColumn.Clear

  aRows = Array(2, 36) 'Rows to copy

For I = LBound(aRows) To UBound(aRows)
    With WS1
            .Range(.Cells(aRows(I), 2), .Cells(aRows(I), .Columns.Count).End(xlToLeft)).Copy
    End With
    rDest.PasteSpecial Paste:=xlPasteValues, skipblanks:=True, Transpose:=True
    Set rDest = WS2.Cells(WS2.Rows.Count, rDest.Column).End(xlUp).Offset(rowoffset:=1)
Next I

With WS2
    Set rSortRange = .Range("B3", .Cells(Rows.Count, "B").End(xlUp))
    rSortRange.Sort key1:=rSortRange, order1:=xlAscending, Header:=xlNo
    .Range("b3").EntireColumn.AutoFit
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Answer 2

I am certian that in the amount of time that I have taken to write this someone might have answered your question already lol, but here's how I'd code it. Please don't be harsh, I am still learning too, so I find that trying to answer these questions helps me get better.

Sub CopyData()

    'Application.ScreenUpdating = False                       'Optional
    'Application.Calculation = xlCalculationManual            'Optional

    Dim lROW1 As String
    Dim lROW2 As String

    'This will find the last row incase it changes often
    lROW1 = Sheets("Sheet1").Range("X65000").End(xlUp).Row   'Replace X for your First list Column Letter
    lROW2 = Sheets("Sheet1").Range("X65000").End(xlUp).Row   'Replace X for your Second list Column Letter

    Sheets("Sheet1").Select
    Range("XX:X" & lROW1).Select                             'Replace XX:X with your first Column Letter and Row Number, replace X with the Column Letter (IE: A1:A)
    Selection Copy

    Sheets("Sheet2").Select
    Range("XX").Select                                       'Replace XX with the Address where you want the data pasted
    Selection.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False


    Sheets("Sheet1").Select
    Range("XX:X" & lROW2).Select                             'Replace XX:X with your Second Column Letter and Row Number, replace X with the Column Letter (IE: A1:A)
    Selection Copy

    Sheets("Sheet2").Select
    Range("XX").Select                                       'Replace XX with the Address where you want the data pasted
    Selection.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

    'Application.ScreenUpdating = True                       'Optional
    'Application.Calculation = xlCalculationAutomatic        'Optional

End Sub