Excel VBA For Each Loop Copying and Pasting info

This is how your code could look like whilst avoiding Select

Sub Copy_Paste()
'
' Copy_Paste Macro
'
' Keyboard Shortcut: Ctrl+w
'
    Dim Current As Worksheet, lRow As Long, lRow3 As Long
    lRow3 = Sheets("Sheet3").Range("K" & Sheets("Sheet3").Rows.Count).End(xlUp).Row + 1
    ' Loop through all of the worksheets in the active workbook.
    For Each Current In ThisWorkbook.Worksheets
        If Current.Name <> "Sheet3" Then
            With Current
                lRow = .Range("K" & .Rows.Count).End(xlUp).Row
                .Range("A2:K" & lRow).Copy
                Sheets("Sheet3").Range("A" & lRow3).Paste
                Debug.Print "Current Sheet was: " & .Name
                lRow3 = lRow3 + lRow 'this already offsets by 1 due to starting at A2
            End With
        End If
    Next Current
End Sub

Notice I used With... End With to avoid having to retype Current over and over again (at the places where there's a dot after a space).

Create a Summary Sheet

Option Explicit
     
Sub CreateSummarySheet()
'
' Copy_Paste Macro
'
' Keyboard Shortcut: Ctrl+w
'
   
    Const PROC_TITLE As String = "Create Summary Sheet"
    
    Const SUMMARY_NAME As String = "Summary"
    Const SHOW_MESSAGES As Boolean = True
   
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Delete existing destination (Summary) sheet.
    
    Dim dsh As Object:
    On Error Resume Next ' prevent error if it doesn't exist
        Set dsh = wb.Sheets(SUMMARY_NAME)
    On Error GoTo 0
    
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False ' delete without confirmation
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Add a new destination worksheet.
    
    Dim dws As Worksheet:
    Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) ' last sheet
    dws.Name = SUMMARY_NAME
    
    Dim dcell As Range: Set dcell = dws.Range("A1")
    
    Application.ScreenUpdating = False
    
    ' Loop and copy.
    
    Dim sws As Worksheet, srg As Range, AreHeadersCopied As Boolean
    
    For Each sws In wb.Worksheets
        If Not sws Is dws Then ' exclude destination worksheet
            With sws.UsedRange
                If AreHeadersCopied Then ' copy headers?
                    Set srg = sws.Range("A2", .Cells(.Cells.CountLarge)) ' no!
                Else
                    Set srg = sws.Range("A1", .Cells(.Cells.CountLarge)) ' yes!
                    AreHeadersCopied = True
                End If
            End With
            srg.Copy dcell
            If SHOW_MESSAGES Then
                MsgBox "Copied ""'" & sws.Name & "'!" & srg.Address(0, 0) _
                    & """ to ""'" & dws.Name & "'!" & dcell.Resize( _
                    srg.Rows.Count, srg.Columns.Count).Address(0, 0) & """.", _
                    vbInformation, PROC_TITLE
            End If
            Set dcell = dcell.Offset(srg.Rows.Count)
         End If
    Next sws
                
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Data copied to the summary sheet.", vbInformation, PROC_TITLE
                
End Sub