Sub УбираемПереносыПробелыE_Лист()
Application.EnableEvents = False

Dim a(), i&, j&
a = ActiveSheet.UsedRange.Value
For i = 4 To UBound(a)
'  For j = 5 To UBound(a, 2)
  For j = 5 To 5
    a(i, j) = Replace(a(i, j), Chr(10), "")
    a(i, j) = Replace(a(i, j), Chr(13), "")
    a(i, j) = Application.WorksheetFunction.Trim(a(i, j))
    a(i, j) = WorksheetFunction.Trim(a(i, j))
  Next
Next
ActiveSheet.UsedRange.Value = a

Application.EnableEvents = True
End Sub

Public AdrE As String
Sub УбираемПереносыПробелыE_Лист ()
Application.ScreenUpdating = False
Application.EnableEvents = False
AdrE = ActiveCell.Address

Dim LastRow As Long, rng As Range
With ActiveSheet.UsedRange

LastRow = ActiveSheet.UsedRange.Rows.Count
'Убираем_пробелы_переносы 4 столбец
ActiveSheet.Range("E4", Cells(LastRow, 5)).Select
Dim RangeE As Range, CellE As Range
Set RangeE = Intersect(Selection, ActiveSheet.UsedRange)

 'переносы 2 видов 4 столбец
RangeE.Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
RangeE.Replace What:=Chr(13), Replacement:=" ", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

For Each CellE In RangeE 'пробелы 4 столбец
CellE.Value = Application.WorksheetFunction.Trim(CellE.Value) 'пробелы внутри строки
CellE.Value = WorksheetFunction.Trim(CellE.Value) 'пробелы снаружи строки
Next 

End With

ActiveSheet.Range(AdrE).Select

Application.EnableEvents = True
Application.ScreenUpdating = True 
End Sub

Private Sub Workbook_Open()
'сохраняем книгу при открытии и по таймеру в каждые 15 мин
Call АвтосохранениеКнига 'сохраняем книгу по таймеру в каждые 15 мин
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'при закрытии книги автосохранение выключается (может открываться книга в закрытом состоянии )
 On Error Resume Next
Application.OnTime EarliestTime:=TimeAvto, Procedure:="АвтосохранениеКнига", Schedule:=False
End Sub 

Public TimeAvto As Date
Sub АвтосохранениеКнига()
TimeAvto = Now + TimeValue("00:15:00")
Application.OnTime TimeAvto, "АвтосохранениеКнига"
End Sub 

ActiveCell.Value = Format(ActiveCell.Value, "dd.mm.yyyy;@")
ActiveCell.NumberFormat = "m/d/yyyy"

Application.ErrorCheckingOptions.TextDate = False
ActiveCell.Value = Format(ActiveCell.Value, "dd.mm.yy;@")
ActiveCell.NumberFormat = "dd/mm/yy;@"

Private Sub UserForm_Initialize()

Dim Arr(), i As Long, s As String, iLastRow As Long, x
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
Arr = Range(Cells(4, 3), Cells(iLastRow, 3))
    On Error Resume Next
    With New Collection
        For Each x In Arr()
            s = Trim(x)
            If Len(s) > 0 Then
                If IsEmpty(.Item(s)) Then
                    For i = 1 To .Count
                        If s < .Item(i) Then Exit For
                    Next
                    If i > .Count Then .Add s, s Else .Add s, s, Before:=i
                End If
            End If
        Next
    ReDim Arr(1 To .Count)
        For i = 1 To .Count
            Arr(i) = .Item(i)
        Next
    End With

Me.ComboBox1.List = Arr

End Sub
  

larr = lsht.[a4].Resize(lLastRow - 3, 6).Value
    iarr = isht.[a4].Resize(iLastRow - 3, 6).Value

.Range("A" & i & ":F" & i).Copy Range("A" & iLastRow)

.Range("A" & i & ":F" & i).Copy Range("A" & iLastRow)
.Range("A" & i & ":F" & i).ClearContents

Range("A" & i & ":F" & i).Copy 
Range("A" & iLastRow).PasteSpecial Paste:=xlPasteValues
Range("A" & i & ":F" & i).ClearContents
 

Sub test()
Dim sht As Worksheet, sht1 As Worksheet
Dim arr(), arr1(), i&, j&, x&
Set sht = Workbooks("ТаблицаKO.xlsm").Sheets(1)
Set sht1 = Workbooks("Новая_выгрузка.xls").Sheets(1)
With sht
    i = .Cells(.Rows.Count, "b").End(xlUp).Row
    'j = .Cells(3, .Columns.Count).End(xlToLeft).Column
    arr = .Range(.Cells(4, "a"), .Cells(i, 6))
End With
With sht1
    i = .Cells(.Rows.Count, "b").End(xlUp).Row
    'j = .Cells(3, .Columns.Count).End(xlToLeft).Column
    arr1 = .Range(.Cells(4, "a"), .Cells(i, 6))
For i = LBound(arr1) To UBound(arr1)

 'както надо перенести здесь

Next i
End With
End Sub

If Range("X1").Resize(.Count) = 0 Then
  ExitSub
  Else
  Range("X1").Resize(.Count) = Application.Transpose(.Keys)
  End If