Option Explicit

Sub Копировать4Строки()
    Dim wsGrusha    As Worksheet
    Set wsGrusha = ThisWorkbook.Worksheets("Груша")

    Dim startRow    As Long
    startRow = ActiveCell.Row

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual

        With ThisWorkbook.Worksheets("Яблоко")

            If ActiveSheet.Name <> .Name Then
                MsgBox "Макрос запускается только с листа 'Яблоко'.", vbExclamation
                Application.Calculation = xlCalculationAutomatic
                Application.DisplayAlerts = True
                Application.ScreenUpdating = True
                Exit Sub
            End If

            Dim targetRow As Long
            targetRow = Application.InputBox("Введите номер строки, куда вставить скопированные строки:", "Строка вставки", Type:=1)
            If targetRow < 1 Then Exit Sub

            .Rows(startRow & ":" & startRow + 3).Copy
            .Rows(targetRow).Insert Shift:=xlDown

            wsGrusha.Rows(startRow & ":" & startRow + 3).Copy
            wsGrusha.Rows(targetRow).Insert Shift:=xlDown
        End With

        .CutCopyMode = False
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox "Готово: строки " & startRow & ":" & (startRow + 3) & " скопированы и вставлены на строку " & targetRow & " на обоих листах.", vbInformation
End Sub

Private Sub CommandButton2_Click()
    Dim wsSistema   As Worksheet
    Set wsSistema = ThisWorkbook.Worksheets("СИСТЕМА")

    Dim LastRowSist As Long
    LastRowSist = wsSistema.Range("B9999").End(xlUp).Row

    With ThisWorkbook.Worksheets("ЧЕК")
        .Range("A5:F9999").ClearContents
        .Range("F1").Value = .Range("F1").Value + 1
        .Range("A4").Value = "Дата:"
        .Range("A4:F4").Borders(xlEdgeBottom).LineStyle = xlDot

        .Range("B4").Value = Format(Now, "dd.mm.yyyy")
        .Range("B4").NumberFormat = "m/d/yyyy"

        .Range("E4").Value = Format(Now, "hh:mm:ss")
        .Range("E4").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"

        With .Range("B4:D4")
            .Merge
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With

        With .Range("E4:F4")
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Dim i As Long, rowDest As Long
        rowDest = 5

        For i = 2 To LastRowSist

            With .Range("A" & rowDest & ":C" & rowDest + 1)
                .Merge
                .WrapText = True
                .VerticalAlignment = xlCenter
                .Value = wsSistema.Cells(i, 2).Value    ' Наименование
            End With

            With .Range("A" & rowDest & ":F" & rowDest + 1)
                .Borders(xlEdgeBottom).LineStyle = xlDot
            End With

            .Cells(rowDest, 4).Value = wsSistema.Cells(i, 4).Value & "*"    ' Кол-во
            .Cells(rowDest, 5).Value = wsSistema.Cells(i, 5).Value          ' Цена
            .Cells(rowDest, 6).Value = wsSistema.Cells(i, 6).Value          ' Сумма
            .Cells(rowDest, 6).NumberFormat = "#,##0.00 _?"

            ' Строка скидки
            .Cells(rowDest + 1, 4).Value = "СК:"
            .Cells(rowDest + 1, 5).Value = ""   ' Неизвестно откуда брать данные ???
            .Cells(rowDest + 1, 6).Value = ""   ' Неизвестно откуда брать данные ???
            .Cells(rowDest + 1, 6).Font.Bold = True

            rowDest = rowDest + 2    ' Следующий товар — через 2 строки
        Next i

        ' Строки Итого и Скидка
        .Cells(rowDest, 5).Value = "Итого:"
        .Cells(rowDest, 6).Value = Me.TextBox3.Value
        .Range(.Cells(rowDest, 5), .Cells(rowDest, 6)).Borders(xlEdgeBottom).LineStyle = xlDot

        .Cells(rowDest + 1, 5).Value = "Скидка:"
        .Cells(rowDest + 1, 6).Value = ""   ' Если появится логика скидок в блоке "Строка скидки" то можно будет просуммировать конечную скидку
        .Range(.Cells(rowDest + 1, 5), .Cells(rowDest + 1, 6)).Borders(xlEdgeBottom).LineStyle = xlDot

        ' Смена №
        With .Cells(rowDest + 2, 1)
            .Value = "Смена №"
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False

            With .Font
                .Name = "Courier New"
                .Size = 8
            End With

        End With

        lastRow = .Range("A:A").Find("*", , xlValues, xlWhole).Row
        Debug.Print lastRow

        With .Range("A" & rowDest - 1 & ": F" & lastRow)
            .Font.Name = "Courier New"
            .Font.Size = 10
            .Font.Italic = True
        End With

        ' Очистка и обновление
        wsSistema.Range("A2:F" & LastRowSist + 1).ClearContents
        UserForm1.ListBox1.Clear

        UserForm1.Label35 = Format(Me.TextBox4, "###0.00")
        UserForm1.Label36 = Format(Me.ItmName, "###0.00")
        wsSistema.Range("L11").Value = CDbl(Me.TextBox3.Value) + CDbl(wsSistema.Range("L11").Value)

        ' Печать
        .PageSetup.PrintArea = "$A$1:$F$50"
        .PrintOut
    End With

    ' Завершение
    Unload Me
    UserForm1.ItmScan.SetFocus
    ItemNum = ""
    ItemQnty = ""
End Sub

Private Sub TextBox4_Change()

    If Me.TextBox4 = Empty Then
        Me.ItmName = ""
        Exit Sub
    Else

        If TextBox4 Like ",*" Then
            Me.ItmName = ""
            Exit Sub
        Else
            Me.ItmName.Text = Me.TextBox4 - Me.TextBox3
            Me.ItmName = Format(Me.ItmName, "fixed")
        End If

    End If

End Sub

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("B4:B10")) Is Nothing Then
        [B1] = ActiveCell
    End If

End Sub

Option Explicit

Sub WtoolkaEvaluate()

    With ThisWorkbook.Worksheets("Лист1")
        Dim i       As Long

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

        For i = 2 To lastRow
            .Cells(i, "D").Value = Evaluate("IFERROR(INDEX($C$1:C" & i - 1 & ", MATCH(LEFT(B" & i & ", FIND(""."", B" & i & ") - 1), $B$1:B" & i - 1 & ", 0)) * C" & i & ", C" & i & ")")
            '            .Cells(i, "D").Formula = "=IFERROR(INDEX($C$1:C" & i - 1 & ", MATCH(LEFT(B" & i & ", FIND(""."", B" & i & ") - 1), $B$1:B" & i - 1 & ", 0)) * C" & i & ", C" & i & ")"
        Next i

    End With

End Sub

            '            .Cells(i, "D").Formula = "=IFERROR(INDEX($C$1:C" & i - 1 & ", MATCH(LEFT(B" & i & ", FIND(""."", B" & i & ") - 1), $B$1:B" & i - 1 & ", 0)) * C" & i & ", C" & i & ")"

            .Cells(i, "D").Value = Evaluate("IFERROR(INDEX($C$1:C" & i - 1 & ", MATCH(LEFT(B" & i & ", FIND(""."", B" & i & ") - 1), $B$1:B" & i - 1 & ", 0)) * C" & i & ", C" & i & ")")

        For i = 1 To rowsToAdd

            Dim newRow As ListRow
            Set newRow = lo1.ListRows.Add

            Dim j   As Long

            For j = 1 To lo1.ListColumns.Count

                With newRow.Range.Cells(1, j)
                    .Formula = lastRow.Range.Cells(1, j).Formula
                End With

            Next j

        Next i

        For i = 1 To rowsToAdd
            lo1.ListRows.Add
        Next i

Option Explicit

Private Sub Workbook_Open()
    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("2")

    Dim lo1 As ListObject, lo3 As ListObject
    Set lo1 = ws.ListObjects("Т")
    Set lo3 = ws.ListObjects("П")

    Dim checkValue As Long, maxValue As Long
    checkValue = lo3.DataBodyRange.Cells(1, 1).Value
    maxValue = Application.WorksheetFunction.Max(lo1.ListColumns(1).DataBodyRange)

    If checkValue = maxValue Then
        MsgBox "Шеф, всё ровно! Будь Здоров!", vbInformation
        Exit Sub
    ElseIf checkValue < maxValue Then
        Dim i       As Long

        ' Удаление строк с пустым значением в столбце "Название"
        Dim nameColIndex As Long
        nameColIndex = lo1.ListColumns("Название").Index

        For i = lo1.ListRows.Count To 1 Step -1

            If Trim(lo1.DataBodyRange(i, nameColIndex).Value) = "" Then
                lo1.ListRows(i).Delete
            End If

        Next i

    Else

        ' Добавление строк, разница между значениями
        Dim rowsToAdd As Long
        rowsToAdd = checkValue - maxValue

        Dim lastRow As ListRow
        Set lastRow = lo1.ListRows(lo1.ListRows.Count)

        For i = 1 To rowsToAdd

            Dim newRow As ListRow
            Set newRow = lo1.ListRows.Add

            Dim j   As Long

            For j = 1 To lo1.ListColumns.Count

                With newRow.Range.Cells(1, j)
                    .Formula = lastRow.Range.Cells(1, j).Formula
                End With

            Next j

        Next i

    End If

End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column <> 4 Then Exit Sub

    ' Проверка: введено ли число (количество)
    If IsNumeric(Target.Value) And Target.Value <> "" Then

        With ThisWorkbook.Worksheets("Лист2")

            Dim article As Variant
            article = Me.Cells(Target.Row, 1).Value
            If article = "" Then Exit Sub

            Dim foundRow As Variant
            foundRow = Application.Match(article, .Columns(1), 0)

            If IsError(foundRow) Then

                Dim lastRow As Long
                lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                If .Cells(1, 1).Value = "" Then lastRow = 1

                .Cells(lastRow, 1).Value = article                          ' Артикул
                .Cells(lastRow, 2).Value = Me.Cells(Target.Row, 4).Value    ' Количество
                .Cells(lastRow, 3).Value = Me.Cells(Target.Row, 5).Value    ' Цена
            Else

                Dim newQty As Variant
                newQty = Me.Cells(Target.Row, 4).Value

                Dim oldQty As Variant
                oldQty = .Cells(foundRow, 2).Value

                If newQty <> oldQty Then
                    .Cells(foundRow, 2).Value = newQty    ' Обновим количество если оно отличается
                End If

            End If

        End With

    End If

End Sub

Option Explicit

Private Sub CommandButton2_Click()
    Dim i           As Long
    Dim iLR         As Long
    Dim ДатаРождения As Date
    Dim Лет         As Integer

    ' Укажите рабочий лист, чтобы избежать неоднозначности
    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("База")

    ' Найти последнюю заполненную строку в столбце A
    Dim iLastRow    As Long
    iLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual

        With ThisWorkbook.Worksheets("ДР")

            ' Очистить диапазон N2:U последней строки
            .Range(.Cells(2, 1), .Cells(.Rows.Count, 9)).ClearContents

            ' Перебирать строки с 2 по последнюю
            For i = 2 To iLastRow

                ' Проверить, находится ли дата в диапазоне от 0 до 30 дней с пропуском пустых ячеек
                If ws.Cells(i, "F").Value <> "" And IsDate(ws.Cells(i, "F").Value) Then

                    If DateSerial(Year(Date), Month(ws.Cells(i, "F")), Day(ws.Cells(i, "F"))) - Date >= 0 And _
                            DateSerial(Year(Date), Month(ws.Cells(i, "F")), Day(ws.Cells(i, "F"))) - Date < 30 Then

                        ' Найти следующую пустую строку в столбце N
                        iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

                        ' Копировать значения
                        .Cells(iLR, "A").Resize(1, 7).Value = ws.Cells(i, "B").Resize(1, 7).Value

                        ' Вычисляем количество лет
                        ДатаРождения = ws.Cells(i, "F").Value
                        Лет = DateDiff("yyyy", ДатаРождения, Date)

                        ' Корректировка, если день рождения в этом году еще не наступил
                        If Month(Date) < Month(ДатаРождения) Then
                            Лет = Лет - 1
                        ElseIf Month(Date) = Month(ДатаРождения) And Day(Date) < Day(ДатаРождения) Then
                            Лет = Лет - 1
                        End If

                        .Cells(iLR, "H").Value = Лет

                        ' Вставляем дату и месяц в столбец U
                        .Cells(iLR, "I").Value = Day(ДатаРождения) & " " & MonthName(Month(ДатаРождения))

                        'Вспомогательный столбец для сортировки, здесь будет храниться дата в числовом формате
                        .Cells(iLR, "J").Value = DateSerial(Year(Date), Month(ДатаРождения), Day(ДатаРождения))

                        If .Cells(iLR, "J").Value < Date Then
                            .Cells(iLR, "J").Value = DateSerial(Year(Date) + 1, Month(ДатаРождения), Day(ДатаРождения))
                        End If

                    End If

                End If

            Next i

            ' Сортировка по столбцу V (вспомогательному, он потом удалится)
            iLR = .Cells(.Rows.Count, "A").End(xlUp).Row

            If iLR > 1 Then    'Убедиться, что есть данные для сортировки

                ' Определяем диапазон для сортировки
                Dim sortRange As Range
                Set sortRange = .Range("A2:J" & iLR)

                ' Сначала убедимся, что SortFields очищены
                .Sort.SortFields.Clear

                ' Добавляем поле сортировки
                .Sort.SortFields.Add Key:=.Range("J2:J" & iLR), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal

                ' Настраиваем параметры сортировки
                With .Sort
                    .SetRange sortRange
                    .Header = xlNo    ' проставить  xlYes, если у есть заголовки (проверь параметр таблицы)
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply    ' Применяем сортировку
                End With

            End If

            'Очистка вспомогательного столбца V
            .Range("J2:J" & iLR).ClearContents
        End With

        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Option Explicit

Sub Рассчитать_ДП()

    With ThisWorkbook.Worksheets("ДР")
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 2)).ClearContents
        ThisWorkbook.Worksheets("База").Range("N2:U" & ThisWorkbook.Worksheets("База").Cells(ThisWorkbook.Worksheets("База").Rows.Count, "N").End(xlUp).Row).Copy Destination:=.Range("B2")
        .Range("A1").Value = "ФО"
    End With

End Sub

Option Explicit

Sub ПодтянутьОбучение()
    Dim i           As Long
    Dim tabNum      As Variant

    Dim dict        As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim filePath    As String
    filePath = ThisWorkbook.Path & "\Обучение_тест.xlsx"

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual

        Dim wbSource As Workbook
        Set wbSource = Workbooks.Open(filePath, ReadOnly:=True)

        Dim wsSource As Worksheet
        Set wsSource = wbSource.Worksheets("Обучение 2025")

        Dim lastRowSource As Long
        lastRowSource = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row

        For i = 2 To lastRowSource
            tabNum = wsSource.Cells(i, "B").Value

            If Not dict.exists(tabNum) Then
                dict.Add tabNum, wsSource.Cells(i, "E").Value
            End If

        Next i

        With ThisWorkbook.Worksheets("Обучение 2019-2025")

            Dim lastRowDest As Long
            lastRowDest = .Cells(.Rows.Count, "B").End(xlUp).Row

            For i = 2 To lastRowDest
                tabNum = .Cells(i, "B").Value

                If dict.exists(tabNum) Then
                    .Cells(i, "D").Value = dict(tabNum)
                Else
                    .Cells(i, "D").Value = "нет данных"
                End If

            Next i

        End With

        wbSource.Close SaveChanges:=False

        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    MsgBox "Данные обучения успешно обновлены!", vbInformation
End Sub

Option Explicit

Sub finka()
    Dim ws As Worksheet, rng As Range, cell As Range, lastCell As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    On Error Resume Next

    For Each ws In ThisWorkbook.Worksheets

        With ws.UsedRange
            Set rng = .SpecialCells(xlCellTypeBlanks)

            If Not rng Is Nothing Then

                With rng
                    .Font.Name = "Calibri"
                    .Font.Size = 11
                    .Interior.ColorIndex = xlNone    ' Убрать заливку
                    .Borders.LineStyle = xlNone      ' Убрать границы
                    .NumberFormat = "General"        ' Формат по умолчанию

                    ' и так далее, можете сами указать (дополнить) необходимыми вами дествиями с ячейками
                End With

            End If

        End With

        Set rng = Nothing
    Next ws

    On Error GoTo 0
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Форматирование пустых ячеек завершено.", vbInformation
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("F4:G4")) Is Nothing Then
        Application.ScreenUpdating = False
        Dim i As Long, lastrow As Long, lastrow2 As Long
        Dim checkDate As Date

        With ThisWorkbook.Worksheets("2018....")

            If Not IsDate(ThisWorkbook.Worksheets("Условка").Range("F4")) Or Not IsDate(ThisWorkbook.Worksheets("Условка").Range("G4")) Then Exit Sub

            Dim startDate As Date
            startDate = CDate(ThisWorkbook.Worksheets("Условка").Range("F4").Value)

            Dim endDate As Date
            endDate = CDate(ThisWorkbook.Worksheets("Условка").Range("G4").Value)

            ThisWorkbook.Worksheets("Условка").Range("A6:H" & ThisWorkbook.Worksheets("Условка").Cells(ThisWorkbook.Worksheets("Условка").Rows.Count, 1).End(xlUp).Row).ClearContents
            lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

            For i = 9 To lastrow

                If IsDate(.Cells(i, 16)) Then
                    checkDate = CDate(.Cells(i, 16).Value)

                    If checkDate >= startDate And checkDate <= endDate Then
                        lastrow2 = ThisWorkbook.Worksheets("Условка").Cells(ThisWorkbook.Worksheets("Условка").Rows.Count, 1).End(xlUp).Row + 1
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 1).Value = .Cells(i, 1).Value     ' № п/п
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 2).Value = .Cells(i, 2).Value     ' Модель шасси
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 3).Value = .Cells(i, 5).Value     ' № лота
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 4).Value = .Cells(i, 3).Value     ' Комплектация
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 5).Value = .Cells(i, 9).Value     ' код VIN
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 6).Value = .Cells(i, 10).Value    ' VIN ISUZU 2
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 7).Value = .Cells(i, 12).Value    ' № двигателя
                        ThisWorkbook.Worksheets("Условка").Cells(lastrow2, 8).Value = .Cells(i, 19).Value    ' Примечание
                    End If

                End If

            Next i

        End With

        Application.ScreenUpdating = True
    End If

End Sub