Modify Copy and Paste script

Sub Copy_Paste()
    Dim wb As Workbook
    Dim fName As String
    Dim strFilePath, lcTargetCell
    Dim strPath As String
    Dim intSrcRows As Integer
    Dim intTgtRows As Integer
    Dim rng As Range
    Dim r As Range
    Dim rDelete As Range
    Dim objFileDLG As Office.FileDialog
    
    
    Application.ScreenUpdating = False
    
    strPath = "D:\\"
    
    
    
    'intTgtRows = 6
    intTgtRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
     
    Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
 
    Do While True
        strFilePath = ""
        With objFileDLG
            .Filters.Add "Excel Files", "*.xls", 1
            .FilterIndex = 1
            .InitialFileName = strPath
            .AllowMultiSelect = False
            .Title = "Select The Workbook to copy From "
            If .Show() <> 0 Then
                strFilePath = .SelectedItems(1)
            End If
        End With
        
        If Trim(strFilePath) = "" Then Exit Do
        
        Set wb = Workbooks.Open(strFilePath)
                
        wb.Activate
        intSrcRows = wb.Worksheets(1).Cells(Cells.Rows.Count, "A").End(xlUp).Row
        wb.Worksheets(1).Range("A2:D" & intSrcRows).Copy
        
        lcTargetCell = "A" & intTgtRows
         
        ThisWorkbook.Worksheets(2).Activate
        Range(lcTargetCell).Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        wb.Close
        Set wb = Nothing
        
        Set rng = Selection.Resize(Selection.Rows.Count, 1)
        For Each r In rng
            If r.Offset(0, 1).Value < "0600" Then
                Debug.Print r.Offset(0, 1).Value, "0600"
                If rDelete Is Nothing Then
                    Set rDelete = r
                Else
                    Set rDelete = Union(rDelete, r)
                End If
            End If
        Next r
        
        rDelete.EntireRow.Delete
        
        intTgtRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row + 1
        

        Set rDelete = Nothing
    Loop
    
    Application.ScreenUpdating = True
End Sub

Select allOpen in new window