Sub KopirovanieIVstavkaVSpisok()
Dim s As String, MyFiles As String, MyRange As String, MyRange2 As String, wb As Workbook


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False

MyFiles = "C:\Users\User\Desktop\Papka3\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    With Workbooks.Open(MyFiles & s)
        
        ' To copy file
        Set wb = Workbooks.Open(MyFiles & s)
        Range("D1").Select ' .Worksheets("Лист1").
        Selection.Copy
                        
        ' To insert file
        ThisWorkbook.Worksheets("Лист2").Select
        MyRange = "A" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        ThisWorkbook.Worksheets("Лист2").Range(MyRange).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        
        ' To copy file
        Set wb = Workbooks.Open(MyFiles & s)
        Range("G8").Select ' .Worksheets("Лист1").
        Selection.Copy
        
        ' To insert file
        ThisWorkbook.Worksheets("Лист2").Select
        MyRange2 = "B" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        ThisWorkbook.Worksheets("Лист2").Range(MyRange2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        .Close SaveChanges:=True
        
    End With
    s = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True

End Sub