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 

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
  

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

Sub Sort()
Application.ScreenUpdating = False
Dim LastRow As Long, i As Long, N As Long, N2 As Long
'N и N2 - количество блоков совпадений на листах Таблица и Работа
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 6 To LastRow
'If Cells(i, 6).Value = Cells(i + 1, 6).Value Then


'как здесь пересортировать только одинаковые строки
'(подтянуть только одинаковые строки по значению столбца  D снизу вверх)
'остальные строки не сортируются
'и N,N2  посчитать

'End If
If N > 0 Or N2 > 0 Then
MsgBox "На листе Таблица найдено" & " " & N & " " & "блоков дубликатов по ФИО" & vbCrLf & _
"На листе Работа найдено" & " " & N2 & " " & "блоков дубликатов по ФИО" & vbCrLf & "", 64, "Итоги поиска дубликатов по ФИО"
End If
If N = 0 And N2 = 0 Then
MsgBox "Ничего не найдено !" & vbCrLf & "Дубликатов нет." & vbCrLf & "", 64, "Итоги поиска дубликатов по ФИО"
End If
Next
Sheets("Работа").Select
Rows("7:10000").EntireRow.AutoFit 'высота строки
Sheets("Таблица").Select
Rows("7:10000").EntireRow.AutoFit 'высота строки
Range("C7").Select
Application.ScreenUpdating = True
End Sub

Sub Srok()
Dim LastRow As Long, i As Long, Num As Long, lDaysCnt As Long
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    lDaysCnt = DateDiff("d", Cells(i, 18).Value, Now)
    For i = 4 To LastRow
        If Cells(i, 10) > 1 And Cells(i, 17) > 1 And lDaysCnt > 365 Then
            Cells(i, 6) = "Истек срок действия"
        End If
    Next
End Sub

Dim wb As Workbook
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\ПАПКА_1\Файл1_" & Format(Date, "dd.mm.yyyy") & "_" & Format(Time, "HH.mm") & ".xlsm")
    Workbooks(wb).Activate
    'Windows(wb).Activate

Function RepeatRange(ByRef SourceRange As Range, ByVal Count As Long, _
                     ByVal Offset As Long, ByVal Direction As XlDirection) As Range
    ' функция получает в качестве параметра диапазон SourceRange,
    ' количество повторений диапазона Count, и шаг смещения Offset
    ' Возвращает диапазон, являющийся объединением копий диапазона SourceRange,
    ' смещённого на Offset ячеек Count раз в направлении Direction.

    Select Case Direction
        Case xlDown: OffsetX = 0: OffsetY = Offset
        Case xlUp: OffsetX = 0: OffsetY = -Offset
        Case xlToRight: OffsetX = Offset: OffsetY = 0
        Case xlToLeft: OffsetX = -Offset: OffsetY = 0
    End Select
 
    Set RepeatRange = SourceRange
    For i = 1 To Count - 1
        Set RepeatRange = Union(RepeatRange, SourceRange.Offset(OffsetY * i, OffsetX * i))
    Next i
End Function


Sub Зебра()
a = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
RepeatRange(Columns(3), a / 2, 2, xlToRight).Interior.ColorIndex = 15
End Sub