Sub Копирование()
Dim strSelTop As String, strSelBottom As String
Application.ScreenUpdating = False

fileToOpen = Application.GetOpenFilename(" (*.*), *.*")
Workbooks.OpenText FileName:=fileToOpen, _
Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
, 1), Array(16, 1)), TrailingMinusNumbers:=True
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Книга1.xlsm").Activate
PS = Range("A" & Rows.Count).End(xlUp).Row
strSelBottom = ActiveCell.Address
strSelTop = Cells(4, ActiveCell.Column).Address
Range(strSelTop & ":" & strSelBottom).Select
Do While Not IsEmpty(ActiveCell.Value)
ActiveCell.Offset(1, 0).Select
Loop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A4").Select
Application.CutCopyMode = False

?????

Application.ScreenUpdating = True
End Sub