Sub num()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lr&
lr = Cells(Rows.Count, 2).End(xlUp).Row
lr = IIf(lr < 5, 5, lr)
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
For i = 5 To lr
    If InStr("Один", Cells(i, 5)) > 0 Then 'Здесь поменял условие
        K = K + 1
        Cells(i, 1) = K
    End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

'Удаление активной строки
Sub RowDelete()
For Each LObj In ListObjects
    If Not Intersect(LObj.Range, ActiveCell) Is Nothing Then
        With LObj
            LObjRow = .Range.Row
            ACelRow = ActiveCell.Row
            RowtoDelete = ACelRow - LObjRow
            For Each cel In .ListRows(RowtoDelete).Range
               If cel.Value <> "" Then Exit Sub
            Next
            .ListRows(RowtoDelete).Delete
            .DataBodyRange(.ListRows.Count, 1).Activate
        End With
Exit For
    End If
Next
End Sub
'Добавление строки внизу
Sub RowInsert()
For Each LObj In ListObjects
    If Not Intersect(LObj.Range, ActiveCell) Is Nothing Then
        With LObj
            .ListRows.Add
            .DataBodyRange(.ListRows.Count, 1).Activate
        End With
Exit For
    End If
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr, WDay As String, DayParam As String
If Target.Address <> "$V$1" Then Exit Sub
ActiveSheet.Range("S3:W" & Cells(Rows.Count, "S").End(xlUp).Row + 1).ClearContents
arr = ActiveSheet.Range("N2:Q" & Cells(Rows.Count, "Q").End(xlUp).Row)
On Error Resume Next
DayParam = Trim(LCase(CStr([V1].Value)))
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        WDay = WeekdayName(Weekday(CDate(arr(i, 2)), vbMonday), , vbMonday)
        If DayParam = WDay And arr(i, 4) <> 0 Then
            .Add .Count, Array(.Count + 1, arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4))
        End If
    Next
[S3].Resize(.Count, 5) = Application.Transpose(Application.Transpose(.items))
[S3].Resize(.Count, 5).Sort Key1:=[W3], Order1:=xlDescending
End With
End Sub

Sub Get_Value_From_Close_Book()
    Dim sShName As String, vAddress, vData
    Dim objCloseBook As Object
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Users\Мария\Downloads\Книга12.xlsm")
    vAddress = Array("G8", "I10", "C14")
    'получаем значения
    vData0 = objCloseBook.Sheets("Лист1").Range("G8").Value
    vData1 = objCloseBook.Sheets("Лист1").Range("I10").Value
    vData2 = objCloseBook.Sheets("Лист2").Range("C14").Value
    vData = Array(vData0, vData1, vData2)
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    For i = 0 To UBound(vData)
        If IsArray(vData(i)) Then
            Range(vAddress(i)).Resize(UBound(vData(i), 1), UBound(vData(i), 2)).Value = vData(i)
        Else
            Range(vAddress(i)) = vData(i)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub SortWithBlanks()
With Sheets(1).Columns(1)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastRow
        If Trim(.Cells(i).Value) = "" Then .Cells(i).Offset(1, 0).CurrentRegion.Sort Key1:=.Cells(i).Offset(1, 0), Order1:=2
    Next
End With
End Sub

Sub CelSplit()
Dim Record
j = 2
For i = 1 To [A1].CurrentRegion.Columns.Count
    Record = Split(Cells(1, i).Value, ",")
    Cells(j, 1).Resize(, 6) = Record
    j = j + 1
Next
End Sub

Public Sub NesRangeSort()
'Определяем первый диапазон
Dim FirstRange As Range
'Определяем последнюю заполненную строку первого диапазона без итога
FLRow = Sheets("Лист4").[A1].CurrentRegion.Rows.Count - 1
Set FirstRange = Sheets("Лист4").Range(Cells(1, 1), Cells(FLRow, 21))
Call SortRangeBy(FirstRange, Array(21, 16, 3), True)

'Определяем второй диапазон
Dim SecondRange As Range
'Определяем первую строку втрого диаазона
SFRow = FLRow + 3
'Определяем конец второго диапазона без итогов
SLRow = Sheets("Лист4").Cells(Rows.Count, 1).End(xlUp).Row
Set SecondRange = Sheets("Лист4").Range(Cells(SFRow, 1), Cells(SLRow, 21))
Call SortRangeBy(SecondRange, Array(21, 16, 3))

End Sub

Public Sub DelSomeRows()

LastRow = Sheets(1).UsedRange.Rows.Count
With Sheets(1).Columns(3)
    For i = LastRow To 1 Step -1
        If InStr(.Cells(i).Value, "<SubCategory>") = 0 Then .Cells(i).EntireRow.Delete
    Next
End With
End Sub

Public Sub Report()

LRow = Cells(Rows.Count, 1).End(xlUp).Row 'последняя заполненная строка в столбце с датами
arr = Range(Cells(1), Cells(LRow, 1))
For i = 1 To UBound(arr)
    If arr(i, 1) <> "" And DatePart("yyyy", CDate(arr(i, 1))) = DatePart("yyyy", Date) Then
        If CDate(arr(i, 1)) = Date Then
            TodayEx = TodayEx + 1
        End If
        If DatePart("ww", CDate(arr(i, 1)), vbMonday) = DatePart("ww", Date, vbMonday) And CDate(arr(i, 1)) <= Date Then
            ThisWeekEx = ThisWeekEx + 1
        End If
        If DatePart("ww", CDate(arr(i, 1)), vbMonday) - DatePart("ww", Date, vbMonday) = -1 Then
            PrevWeekEx = PrevWeekEx + 1
        End If
        If DatePart("m", CDate(arr(i, 1))) = DatePart("m", Date) And CDate(arr(i, 1)) <= Date Then
            ThisMonthEx = ThisMonthEx + 1
        End If
        If DatePart("m", CDate(arr(i, 1))) - DatePart("m", Date) = -1 Then
            PrevMonthEx = PrevMonthEx + 1
        End If
        If DatePart("q", CDate(arr(i, 1))) = DatePart("q", Date) And CDate(arr(i, 1)) <= Date Then
            ThisQuarterEx = ThisQuarterEx + 1
        End If
        If CDate(arr(i, 1)) <= Date Then
            ThisYearEx = ThisYearEx + 1
        End If
    End If
Next

Cells(18, 8) = TodayEx
Cells(18, 9) = ThisWeekEx
Cells(18, 10) = PrevWeekEx
Cells(18, 11) = ThisMonthEx
Cells(18, 12) = PrevMonthEx
Cells(18, 13) = ThisQuarterEx
Cells(18, 14) = ThisYearEx


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.Range("D9:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If Not Intersect(Target, WorkRange.Cells) Is Nothing Then
    If Target.Value = "сделал" Then
        RowToCopy = Sheets("итоговая").Cells(8, 2).CurrentRegion.Rows.Count + 8
        Set RangeToCopy = Range(Target.Offset(, -2), Target.Offset(, -1))
        RangeToCopy.Copy Destination:=Worksheets("итоговая").Cells(RowToCopy, 2)
    End If
End If
End Sub

Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.Range("A10:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub

Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[A10].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub

Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[B5].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 2)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 2).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
        Next
        If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add CStr(arr(i, 1)) & ";" & CStr(arr(i, 3)), ""
        Next
        If oDic.exists(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value)) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub

Public Sub RangesCopy()
Application.ScreenUpdating = False
Dim TextToCopy As String
With CreateObject("scripting.dictionary")
    Sheets(1).Activate
    TextToCopy = Cells(2, 2).Value
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
       .Add .Count, TextToCopy
       If Cells(i, 2).Style <> Cells(i + 1, 2).Style Then TextToCopy = Cells(i + 1, 2).Value
    Next
Cells(2, 1).Resize(.Count, 1) = Application.Transpose(.items)
End With
Application.ScreenUpdating = True
End Sub

Public Sub RangeCopy()
Dim arr()
With CreateObject("scripting.dictionary")
    Set a = Workbooks("Лист Microsoft.xlsm").Sheets("vv")
    arr = a.UsedRange.Value
    'Находим номер столбца с заголовком "наличие"
    NumCol = Application.Match("наличие", Application.Index(arr, 1))
    'Определяем количество столбцов в масииве
    QntCol = UBound(arr, 2)
    For i = 1 To UBound(arr)
        If arr(i, NumCol) <> "" Then
            .Add .Count, Application.Index(arr, i)
        End If
    Next
    arr = .items
    Set b = ThisWorkbook.Sheets("vv")
    b.Cells(1).Resize(.Count, QntCol) = Application.Transpose(Application.Transpose(arr))
    b.ListObjects.Add(xlSrcRange, b.Cells(1).CurrentRegion, , xlYes).Name = a.ListObjects(1).Name
End With