How can I simplify using active cell / copy / paste to transfer data between sheet?

Question

I am trying to transfer the data from sheet one to sheet two and combined the information on the second sheet. The code I have listed below works, but it seems very inefficient. I am trying to improve by VBA abilities and would love to here ways to shrink my code down, make it more efficient, and still achieve the same goal. Thanks for any help you can provide.

Sheet 1 Sheet 2

Sub batchorder()
Dim Pname As String
Dim Lplace As String
Dim numsld As Long
Dim rating As Integer
Dim lastrow As Long
Dim i As Long
Dim openc As Long


lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select

For i = 1 To lastrow
    If Cells(i, 1).Value <> "" Then
        'Copy name to sheet 2
        Cells(i, 1).Select
        ActiveCell.Offset(0, 1).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A1").Select
        'Find the next open cell to paste to
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
            'Copy place to sheet 2
             ActiveCell.Offset(1, 0).Select
             Selection.Copy
             Sheets("Sheet2").Select
             Range("B1").Select
            'Find the next open cell to paste to
            Selection.End(xlDown).Select
            Selection.End(xlDown).Select
            Selection.End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
            Sheets("Sheet1").Select
                'Copy sold to sheet 2
                 ActiveCell.Offset(1, 0).Select
                 Selection.Copy
                 Sheets("Sheet2").Select
                 Range("C1").Select
                'Find the next open cell to paste to
                Selection.End(xlDown).Select
                Selection.End(xlDown).Select
                Selection.End(xlUp).Select
                ActiveCell.Offset(1, 0).Select
                ActiveSheet.Paste
                Sheets("Sheet1").Select
                    'Copy rating to sheet 2
                     ActiveCell.Offset(1, 0).Select
                     Selection.Copy
                     Sheets("Sheet2").Select
                     Range("D1").Select
                    'Find the next open cell to paste to
                    Selection.End(xlDown).Select
                    Selection.End(xlDown).Select
                    Selection.End(xlUp).Select
                    ActiveCell.Offset(1, 0).Select
                    ActiveSheet.Paste
                    Sheets("Sheet1").Select
    Sheets("Sheet1").Select
    i = i + 3
    Else
    End If
Next i

End Sub

Answer 1

Sub batchorder()


    Dim Row As Long
    Dim i As Long

    ' These two lines speed up evrything ENORMOUSLY. 
    ' But you need the lines at the end too
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Row = Sheet2.UsedRange.Rows.Count  ' Row is nr of last row in sheet

    While Application.CountA(Sheet2.Rows(Row)) = 0 And Row > 1
        Row = Row - 1 ' skip empty rows at the end if present
    Wend

    For i = 1 To Sheet1.UsedRange.Rows.Count
        If Sheet1.Cells(i, 1).Value <> "" Then
            Sheet2.Cells(Row, 1).FormulaLocal = Sheet1.Cells(i, 2).FormulaLocal
            Sheet2.Cells(Row, 2).FormulaLocal = Sheet1.Cells(i + 1, 2).FormulaLocal
            Sheet2.Cells(Row, 3).FormulaLocal = Sheet1.Cells(i + 2, 2).FormulaLocal
            Sheet2.Cells(Row, 4).FormulaLocal = Sheet1.Cells(i + 3, 2).FormulaLocal
            i = i + 3
            Row = Row + 1
        End If
    Next

    ' Restore Excel to human state.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

You should basically never use the select statement, it gets everything really messy quickly. Here's a basic combiner of mine. Just added the If statement to check whether the cell and in this case row is empty.

This should work but more importantly try to understand what it does to learn. I gave it some comments.

Sub batchorder()
Dim ws1 As Worksheet
Dim ws2 As Worksheet

' Just habits, but doing this here means that I won't have to write anything else than ws1 and ws2 in the future
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Dim lastrowWs1 As Long
Dim j As Long
' first row after ws2 headers
j = 2


' With statement to make the code nicer also ".something" now means ws1.something
With ws1

' Bob Ulmas method -- just a personal preference to find the last row.
lastrowWs1 = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

For i = 1 To lastrowWs1
    ' Check if the cell is not empty
    If Not .Cells(i, 1) = vbNullString Then
        'Basically range.value = other_range.value
        ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 4)).Value = WorksheetFunction.Transpose(.Range(.Cells(i, 2), .Cells(i + 3, 2)).Value)
        ' step 3 forward as the amount of rows per record was 4
        i = i + 3
        ' go to next row for worksheet 2
        j = j + 1
    End If
Next i

End With


End Sub