Function DaysUntilToday(startDate as Date) as long
Dim futureDate as Date
futureDate = DateAdd("m", 2, startDate)
DaysUntilToday = DateDiff("d", Date, startDate)
DaysUntilToday = Abs(DaysUntilToday)
End function

Sub UUU()
Dim sss as String
i = ActiveCell.Row
sss = "B" & i
Cells(i, 11).Folmula = "=DaysUntilToday(sss)"
End Sub

Sub Test()
Dim arr, i

With Sheets("in")
    arr = Application.Transpose(.Range(.[A1], .Cells(Rows.Count, "A").End(xlUp)))
End With
For i = LBound(arr) To UBound(arr)
     arr(i) = CStr(arr(i))
Next i

Worksheets("Лист1").ListObjects("Таблица1").Range.AutoFilter Field:=3, Criteria1:=arr, Operator:=xlFilterValues
End Sub

Sub Test()
Dim MyArray() As Variant
Dim arr() As Variant

LastRow = Sheets("in").Cells(Rows.Count, 1).End(xlUp).Row
MyArray = Sheets("in").Range(Cells(1, 1), Cells(LastRow, 1)).Value

ReDim arr(1 To UBound(MyArray))

For i = LBound(MyArray) To UBound(MyArray)
        arr(i) = MyArray(i, 1)
Next

Worksheets("Лист1").ListObjects("Таблица1").Range.AutoFilter Field:=3, Criteria1:=arr, Operator:=xlFilterValues
End Sub

Sub CodeCopy()

  'Macro to create a new sheet and copy the macro module
  'from sheet1 to it.  Must install Microsoft Visual Basic
  'for Applications Extensibility library from Tools > References.
  
  Dim i          As Integer
  Dim NewSh      As Worksheet
  Dim SrcCmod    As VBIDE.CodeModule
  Dim DstCmod    As VBIDE.CodeModule
  
  Set NewSh = Worksheets.Add(after:=Worksheets(Worksheets.Count))

  Set SrcCmod = ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
  Set DstCmod = ActiveWorkbook.VBProject.VBComponents(NewSh.Name).CodeModule
  
  For i = 1 To SrcCmod.CountOfLines
     DstCmod.InsertLines i, SrcCmod.Lines(i, 1)
  Next i
  
End Sub

'Option Explicit
'Public iLastRow As Long
Const FIRST_ROW& = 1

Sub CreatePageSubtotals5555()
Dim iPageNum&, viewState, hpb As HPageBreak, iRow1&, iRow2&
Dim lLastRow As Long
Dim Ws As Worksheet
Set Ws = Sheets("Реестр от __.__.____")
viewState = ActiveWindow.View
ActiveWindow.View = xlPageBreakPreview
iRow1 = FIRST_ROW
For Each hpb In ActiveSheet.HPageBreaks
    iPageNum = iPageNum + 1
    'iRow2 = hpb.Location.Row - 9
    lLastRow = hpb.Location.Row - 9
    Rows(lLastRow).Resize(9).Insert
    
    ''-------------------------------------
    '' ПОДВАЛ
Range(Ws.Cells(lLastRow - 1, 1), Ws.Cells(lLastRow - 1, 6)).Borders(xlEdgeBottom).Weight = xlMedium
Range(Ws.Cells(lLastRow, 1), Ws.Cells(lLastRow + 8, 6)).Clear

Ws.Cells(lLastRow + 3, 2) = "СДАЛ:"
Ws.Cells(lLastRow + 3, 2).Font.Bold = True
Ws.Cells(lLastRow + 3, 3).Borders(xlEdgeBottom).Weight = xlThin
Range(Ws.Cells(lLastRow + 3, 4), Ws.Cells(lLastRow + 3, 5)).Merge
Range(Ws.Cells(lLastRow + 3, 4), Ws.Cells(lLastRow + 3, 5)).HorizontalAlignment = xlCenter
Range(Ws.Cells(lLastRow + 3, 4), Ws.Cells(lLastRow + 3, 5)).Font.Bold = True
Range(Ws.Cells(lLastRow + 3, 4), Ws.Cells(lLastRow + 3, 5)).Value = "ПРИНЯЛ:"

Ws.Cells(lLastRow + 3, 6).Borders(xlEdgeBottom).Weight = xlThin
Ws.Cells(lLastRow + 4, 3) = "(подпись)"
Ws.Cells(lLastRow + 4, 3).HorizontalAlignment = xlCenter
Ws.Cells(lLastRow + 4, 3).Font.Size = 7
Ws.Cells(lLastRow + 4, 3).VerticalAlignment = xlTop
Ws.Cells(lLastRow + 4, 6) = "бригадир"
Ws.Cells(lLastRow + 4, 6).HorizontalAlignment = xlCenter
Ws.Cells(lLastRow + 4, 6).Font.Size = 7
Ws.Cells(lLastRow + 4, 6).VerticalAlignment = xlTop
Ws.Cells(lLastRow + 6, 3) = "М.П."
Ws.Cells(lLastRow + 6, 6).Borders(xlEdgeBottom).Weight = xlThin
Ws.Cells(lLastRow + 7, 6) = "контролер"
Ws.Cells(lLastRow + 7, 6).HorizontalAlignment = xlCenter
Ws.Cells(lLastRow + 7, 6).Font.Size = 7
Ws.Cells(lLastRow + 7, 6).VerticalAlignment = xlTop
Range(Ws.Cells(lLastRow + 7, 3), Ws.Cells(lLastRow + 7, 6)).Borders(xlEdgeBottom).Weight = xlMedium
Ws.Cells(lLastRow + 8, 3) = "Примечание:"
Ws.Cells(lLastRow + 8, 3).Font.Bold = True
Ws.Cells(lLastRow + 8, 3).Font.Color = RGB(191, 191, 191)
Range(Ws.Cells(lLastRow + 8, 4), Ws.Cells(lLastRow + 8, 6)).Merge
Range(Ws.Cells(lLastRow + 8, 4), Ws.Cells(lLastRow + 8, 6)).Borders(xlEdgeBottom).Weight = xlMedium
Range(Ws.Cells(lLastRow + 8, 4), Ws.Cells(lLastRow + 8, 6)).Borders.Color = RGB(191, 191, 191)

   ''----------------------------------------------------
'    Cells(iRow2, ITOGO_COL) = "Итого по странице " & iPageNum & ":"
'    Range(Cells(iRow2, FIRST_COL), Cells(iRow2, LAST_COL)).FormulaR1C1 = _
'        "=SUBTOTAL(9,R[" & iRow1 - iRow2 & "]C:R[-1]C)"
'    Rows(iRow2).Font.Bold = True
    iRow1 = lLastRow '+ 9
Next
'iRow2 = Cells(Rows.Count, FIRST_COL).End(xlUp).Row + 1
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row '+ 9 'hpb.Location.Row - 9

ActiveWindow.View = viewState
End Sub

Private Sub CommandButton1_Click()
lRow = WorksheetFunction.CountA(Range("B:B")) + 1
i = lRow - 1

strana = ComboBox1.Value
raion = ComboBox2.Value
gorod = "г. " & TextBox1.Text
ulica = TextBox2.Text
dom = "д. " & TextBox3.Text
kvartira = "кв. " & TextBox4.Text

Addr = strana & ", " & raion & ", " & gorod & ", " & ulica & ", " & dom & ", " & kvartira ' если поле пустое получается лишняя запятая
'Addr = Replace(Application.Trim(strana & " " & raion & " " & gorod & " " & ulica & " " & dom & " " & kvartira), " ", ", ") ' вставляет запятую 
 'вместо каждого пробела вообще везде


Sheets(1).Cells(lRow, 2).Value = i
Sheets(1).Cells(lRow, 5).Value = Addr
Unload Me
End Sub

Private Sub UserForm_Initialize()
With Me.ComboBox1
.AddItem "Россия"
.AddItem "Уганда"
End With
With Me.ComboBox2
.AddItem "Ханты-Мансийский АО"
.AddItem "Северо-западный район"
End With

Sub SaveFile()
    Dim F_Filename$, Folder$, Folder2$
    Dim strDate As String
    Dim strPath As String
    Dim DogNumb As String
    Dim wsTmpSh As Worksheet
    Dim Rgg As Range
    Set Rgg = ActiveSheet.Range("A1:F43")
    strPath = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ"
    Dim sFileName As String, sNewFileName As String
    Dim a As String
    a = Range("F3")
    
   DogNumb = Sheets("ФУРШЕТ").Range("F4").Value
    
    F_Filename$ = [C4] 'Split([C4], ".")(0)
    Folder$ = strPath & "\" & [C5] & " " & F_Filename
    Folder2$ = strPath & "\" & "КАРТИНКИ"
    strDate = Format(ActiveSheet.Range("$C$5"), "dd/mm/yy")
    On Error Resume Next: MkDir Folder$
 
     Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' вывод в PDF
    ActiveSheet.PageSetup.PrintArea = "$A$1:$F$43" ', Type:=2)
    Подготовить
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Folder & "\" & strDate & " " & F_Filename & ".pdf"

    ' сохранить JPG
        With Rgg
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Paste
            .Export Filename:=Folder2 & "\" & strDate & " " & "ДОГОВОР (Ю)-" & DogNumb & " " & strDate & " " & ".jpeg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete

    ' сохранение в XLS

    Err.Clear: ActiveSheet.Copy: DoEvents ' копируем активный лист (при этом создаётся новая книга)
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Folder & "\" & strDate & " " & F_Filename & ".xls", xlWorkbookNormal
        ActiveWorkbook.Close False ' закрываем сохранённый файл
    End If
 
 
    Вернуть
    Select Case a
    Case "Ф"
        sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ФИЗ ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ф)-" & DogNumb & ". " & strDate & ".doc"     'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    
    FileCopy sFileName, sNewFileName 'копируем файл
    Case "Ю"
            sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ЮР ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ю)-" & DogNumb & ". " & strDate & ".doc" 'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
    End Select
     Sheets("ФУРШЕТ").Range("F4").Value = _
     Sheets("ФУРШЕТ").Range("F4").Value + 1
'  ThisWorkbook.Save
    Shell "explorer.exe " & Folder, vbMaximizedFocus
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub Подготовить()
 Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A2:F2,A11:F11").Interior.Color = RGB(220, 220, 220)
    Range("F3:F4").Font.Color = vbWhite
End Sub
Sub Вернуть()
    Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("F3:F4").Font.Color = vbRed
End Sub

Function ЧАСИКС(сутки, начало, конец)
'On Error Resume Next
If (начало.Value = 0) Then
 Exit Function
Else
If конец <= начало Then
ЧАСИКС = (конец + сутки) - начало
Else
ЧАСИКС = конец - начало
End If
    End If
End Function
 

Function ЧАСИКС(сутки, начало, конец)
If начало = "" Or конец = "" Then
ЧАСИКС = ""
Exit Function
If конец <= начало Then
ЧАСИКС = (конец + сутки) - начало
Else
ЧАСИКС = конец - начало
End If
    End If
End Function