Private Sub TextBox1_Change()
    If Not IsNumeric(TextBox1) Or Val(TextBox1) <= 0 Then Exit Sub
    Лист2.[C6:C8] = Application.Transpose(Лист1.[B4:D4].Offset(TextBox1))
End Sub

Function ЗаменитьБукву$(s$)
    With CreateObject("scriptcontrol")
        .Language = "JScript"
        ЗаменитьБукву = .eval("'" & s & "'.replace(/(?:^|\b)([a-z])/gi, " & _
            "function(a) { return a.toUpperCase(); })")
    End With
End Function

Sub ertert()
Dim wsh As Worksheet, dt As Date, x, y(), i&, k&
dt = Range("A1").Value
Range("A1").CurrentRegion.Offset(1).ClearContents

For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is ActiveSheet Then
        x = wsh.Range("I1").CurrentRegion.Value
        If Not IsEmpty(x) Then
            k = 0
            ReDim y(1 To UBound(x), 1 To 4)
            For i = 1 To UBound(x) Step 2
                If x(i, 1) = dt Then
                    k = k + 1
                    y(k, 1) = dt
                    y(k, 2) = x(i + 1, 1)
                    y(k, 3) = x(i, 2)
                    y(k, 4) = x(i + 1, 2)
               End If
            Next i
         End If
    If k > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(k, 4).Value = y()
    End If
Next wsh

Option Explicit
    'константы для функций API
    Private Const GWL_STYLE As Long = -16& 'для установки нового вида окна
    Private Const GWL_EXSTYLE = -20& 'для расширенного стиля окна
    Private Const WS_CAPTION As Long = &HC00000 'определяет заголовок
    Private Const WS_BORDER As Long = &H800000 'определяет рамку формы
    
    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const HTCAPTION = 2
    
    'Функции API, применяемые для поиска окна и изменения его стиля
#If VBA7 Then
    Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long

    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA"  (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    
    Dim ihWnd As LongPtr
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long

    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    
    Dim ihWnd As Long
#End If

Private Sub UserForm_Initialize()
    Dim hStyle
    'ищем окно формы среди всех открытых окон
    If VAL(Application.Version) < 9 Then
        ihWnd = FindWindow("ThunderXFrame", Me.Caption) 'для Excel 97
    Else
        ihWnd = FindWindow("ThunderDFrame", Me.Caption) 'для Excel 2000 и выше
    End If
    'получаем информацию о найденном окне(стили и т.д.)
    hStyle = GetWindowLong(ihWnd, GWL_STYLE)
    'назначаем переменной новый стиль для окна формы
    hStyle = hStyle And Not WS_CAPTION And Not WS_BORDER
    'изменяем вид окна: убираем меню(заголовок) и рамку
    SetWindowLong ihWnd, GWL_STYLE, hStyle
    SetWindowLong ihWnd, GWL_EXSTYLE, 0
    'перерисовываем форму, точнее строку меню(заголовка)
    DrawMenuBar ihWnd
    'меняем размер формы, т.к. сделали смещение элементов формы вверх на высоту заголовка
    Me.Height = Me.Height + GWL_EXSTYLE
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        ReleaseCapture
        SendMessage ihWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    End If
End Sub

Private Sub ЗАКРЫТЬ_Click()
    Unload Me
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    With Target
        If .NumberFormat = "[h]:mm:ss" And Int(.Value) = .Value Then
            Application.EnableEvents = False
            .Formula = Format(.Formula, "00:00:00")
            .NumberFormat = "[h]:mm:ss"
            Application.EnableEvents = True
        End If
    End With
End Sub

=ЕСЛИОШИБКА(ОСТАТ(ПСТР(ПОДСТАВИТЬ(","&$A1;",";ПОВТОР(" ";99));99*СТОЛБЕЦ(A1);99);10^7);"")

=C2=КОНМЕСЯЦА(B2;0)+1

Option Explicit

Private LO As ListObject
Private index%

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set LO = Nothing
End Sub

Private Sub ИмяПациента_Change()

End Sub

Private Sub ИмяТовара_Change()

End Sub

Private Sub КачествоТовара_Change()

End Sub

Private Sub КоличествоТовара_Change()

End Sub

Private Sub UserForm_Initialize()
    Set LO = [Таблица2].ListObject
    With LO
        If Intersect(.DataBodyRange, Selection) Is Nothing Then
            Set LO = Nothing
            Exit Sub
        End If
        index = Selection.Row - .HeaderRowRange.Row
        With .ListColumns
            Me.ИмяПациента = .Item("Имя").DataBodyRange(index)
            Me.ИмяТовара = .Item("Товар").DataBodyRange(index)
            Me.КоличествоТовара = .Item("Количество").DataBodyRange(index)
            Me.КачествоТовара = .Item("Качество").DataBodyRange(index)
        End With
    End With
End Sub

Private Sub Редактура_Click()
    LO.ListRows(index).Range = Array(ИмяПациента, ИмяТовара, КоличествоТовара, КачествоТовара)
End Sub

Private Sub ОчисткаФормы_Click()
    Me.ИмяПациента = Empty
    Me.ИмяТовара = Empty
    Me.КоличествоТовара = Empty
    Me.КачествоТовара = Empty
End Sub

Private Sub СозданиеНового_Click()
    LO.ListRows.Add.Range = Array(ИмяПациента, ИмяТовара, КоличествоТовара, КачествоТовара)
End Sub

Private Sub Выход_Click()
    Unload Me
End Sub

Function Перенос$(s$)
    With CreateObject("vbscript.regexp")
        .Pattern = "(\d{1,3}(?=\d{4}))|\d+"
        .Global = True
        s = .Replace(StrReverse(s), "$1 ")
    End With
    Перенос = StrReverse(Application.Trim(s))
End Function

Sub ertert()
Dim wsh As Worksheet, dt As Date, x, y(), i&, k&
dt = Range("A1").Value
Range("A1").CurrentRegion.Offset(1).ClearContents

For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is ActiveSheet Then
        x = wsh.Range("I1").CurrentRegion.Value
        If Not IsEmpty(x) Then
            k = 0
            ReDim y(1 To UBound(x), 1 To 5)
            For i = 1 To UBound(x) Step 2
                If x(i, 1) = dt Then
                    k = k + 1
                    y(k, 1) = dt
                    y(k, 2) = x(i + 1, 1)
                    y(k, 3) = x(i, 2)
                    y(k, 4) = x(i + 1, 2)
                    y(k, 5) = wsh.Name
                End If
            Next i
            If k > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(k, 5).Value = y()
        End If
    End If
Next wsh

With Range("B1:F" & Cells(Rows.Count, 2).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
          Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
End With
End Sub

Option Explicit

Sub ertert()
Dim wsh As Worksheet, dt As Date, x, y(), i&, k&
dt = Range("A1").Value
Intersect(ActiveSheet.UsedRange.Offset(1), [B:F]).ClearContents

For Each wsh In ThisWorkbook.Sheets
    If Not wsh Is ActiveSheet Then
        x = wsh.Range("I1").CurrentRegion.Value
        If Not IsEmpty(x) Then
            k = 0
            ReDim y(1 To UBound(x), 1 To 5)
            For i = 1 To UBound(x) Step 2
                If x(i, 1) = dt Then
                    k = k + 1
                    y(k, 1) = dt
                    y(k, 2) = x(i + 1, 1)
                    y(k, 3) = x(i, 2)
                    y(k, 4) = x(i + 1, 2)
                    y(k, 5) = wsh.Name
                End If
            Next i
            If k > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(k, 5).Value = y()
        End If
    End If
Next wsh

With Range("B1:F" & Cells(Rows.Count, 2).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
        Key2:=.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
End With
End Sub

=(МУМНОЖ(ОТБР(A2:B2);{-1:1})*12-МУМНОЖ(-ТЕКСТ(ТЕКСТ(ОСТАТ(A2:B2;1)*24;"[>20]2\0");"[<8]8");{-1:1}))/24

=((ОТБР(B2)-ОТБР(A2))*12-СУММ(ТЕКСТ(ТЕКСТ(ОСТАТ(A2:B2;1)*24;"[>20]2\0");"[<8]8")*{1;-1}))/24

Sub ExportToXML()
    Dim strPath As String, sTmp As String
    strPath = ThisWorkbook.Path & "\счет.xml"
    ThisWorkbook.XmlMaps("Файл_карта").Export URL:=strPath
    DoEvents
    With CreateObject("ADODB.Stream")
        .Type = 2: .Charset = "utf-8"
        .Open: .LoadFromFile strPath: sTmp = .ReadText: .Close
        .Charset = "windows-1251": sTmp = Replace(sTmp, "UTF-8", "windows-1251")
        .Open: .WriteText sTmp: .SaveToFile strPath, 2: .Close
    End With
End Sub