Private Sub CommandButton3_Click()
Dim ctl As Control
For Each ctl In Me.Controls
    If InStr(ctl.Name, "TextBox") Then
        If Len(ctl.Text) = 0 Then ctl.Value = 0
    End If
Next ctl
End 

Private Sub CommandButton1_Click()
Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(, 2).Value = _
Array(Date, Me.TextBox1.Value & "; " & Me.TextBox2.Value & "; " & Me.TextBox3.Value)
End Sub

Sub ertert()
Dim x, bz, y(), i&, j&, k&

x = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
bz = Range("E2:F" & Cells(Rows.Count, 5).End(xlUp).Row).Value
ReDim y(1 To UBound(x) * UBound(bz), 1 To 3)

For i = 2 To UBound(bz)
    For j = 2 To UBound(x)
        k = k + 1
        y(k, 1) = x(j, 1)
        y(k, 2) = bz(i, 1)
        y(k, 3) = bz(i, 2)
    Next j
Next i

Range("H3").Resize(k, 3).Value = y()
End Sub

Sub ertert()
Dim x, i&, j&, s$
With Range("A1").CurrentRegion
    x = .Value
    For i = 1 To UBound(x)
        If x(i, 1) <> s Then
            s = x(i, 1)
            j = i
        Else
            x(j, 2) = x(j, 2) & ", " & x(i, 2)
            x(i, 1) = "": x(i, 2) = ""
        End If
    Next i
    .Value = x
End With
End Sub

Sub ertert()
Dim x, s$, i&, k&
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
    x = .Value
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            s = x(i, 1): k = 0
        Else
            k = k + 1
            x(i, 1) = s & "-" & k
        End If
    Next i
    .Value = x
End With
End Sub

With Range("A2").CurrentRegion.Resize(, 3).Offset(2)
    .ClearContents' очищаем диапазон перед вставкой данных
    If k > 0 Then .Resize(k).Value = y()
End With

Sub ttt()
Dim wsh As Worksheet
With Application
    .DisplayAlerts = False
    For Each wsh In ThisWorkbook.Sheets
        If InStr(wsh.Name, "_") Or InStr(wsh.Name, "!") Then wsh.Delete
    Next wsh
    .DisplayAlerts = True
End With
End Sub

Private Sub ComboBox1_Change()
Dim x, y(), i&, s$, k&
If Me.ComboBox1.ListIndex = -1 Then Exit Sub

x = Sheets("data").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 3)
s = Me.ComboBox1.Value

For i = 2 To UBound(x)
    If x(i, 4) = s Then
        k = k + 1
        y(k, 1) = x(i, 1)    'HouseID
        y(k, 2) = x(i, 2)    'Адрес
        y(k, 3) = x(i, 3)    'Клиентов
    End If
Next i

With Range("A2").CurrentRegion.Offset(2)
    .ClearContents
    If k > 0 Then .Resize(k).Value = y()
End With
End Sub

Function VidD(rOtm As Range, rVid As Range) As String
Dim x, y, j&, s$
x = rOtm.Value
y = rVid.Value
For j = 1 To UBound(x, 2)
    If Len(x(1, j)) Then s = s & ", " & y(1, j)
Next j
VidD = Mid(s, 3)
End Function

Private Sub CommandButton1_Click()
Dim x, i&
x = Sheets("Расход").Range("A1:A10").Value    'данные в массив
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x)
        .Item(x(i, 1)) = 1
    Next i
    '    в столбик
    [A1].Resize(.Count).Value = Application.Transpose(.keys)
    '    в строку
    [B1].Resize(, .Count).Value = .keys
End With
End Sub

Sub ertert()
Dim x, i&, v
x = Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        For Each v In Split(x(i, 1), ",")
            .Item(v) = Empty
        Next v
    Next i
    Range("A23").Resize(.Count).Value = Application.Transpose(.keys)
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
    .Range("E3").Value = Cells(Target.Row, 3).Value
    .Range("I3").Value = Cells(2, Target.Column).Value
    .Activate
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
    .Cells(Rows.Count, 5).End(xlUp)(2, 1).Value = Cells(Target.Row, 3).Value
    .Cells(Rows.Count, 9).End(xlUp)(2, 1).Value = Cells(2, Target.Column).Value
End With
End Sub

Sub ertert()
Dim magz As Range, b As Range, poisk As Range, r As Range
Dim i As Long, l As Long
'Список самих магазинов, искомые значения:
Set magz = Range([a1], Cells(Rows.Count, 1).End(xlUp))
'Поисковый столбец, в котором ищем значения определенных магазинов:
Set poisk = Range([e1], Cells(Rows.Count, 5).End(xlUp))
poisk.Font.ColorIndex = xlAutomatic: magz.Font.ColorIndex = xlAutomatic

With CreateObject("VBScript.RegExp")
    .Global = True: .IgnoreCase = True
    For Each b In magz.Cells
        .Pattern = b.Value: l = 5
        For Each r In poisk.Cells
            If .Test(r) Then
                b.Font.Color = vbBlue
                With .Execute(r)
                    For i = 0 To .Count - 1
                        'совпадения выделяем красным
                        r.Characters(.Item(i).FirstIndex + 1, l + 1).Font.Color = vbRed
                    Next
                End With
            End If
        Next r
    Next b
End With
End Sub

Sub ertert()
Dim a, x, i As Long, j As Long, temp$

a = Range("A7").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(a)
        .Item(CStr(a(i, 3))) = 0    'По договору №
    Next i

    x = Sheets("Расход").Range("A1").CurrentRegion.Value
    For i = 2 To UBound(x)    'отбираем данные расхода
        If x(i, 7) <> "В" Then
            temp = Split(x(i, 2), "|")(1)    'договор
            If .exists(temp) Then .Item(temp) = .Item(temp) + x(i, 4)     'Кол-во расход
        End If
    Next i

    x = Sheets("Приход").Range("A1").CurrentRegion.Value
    For i = 2 To UBound(x)    'отбираем данные прихода
        temp = CStr(x(i, 2))
        If .exists(temp) Then
            .Item(temp) = .Item(temp) * x(i, 9)  'кол-во*цену
        End If
    Next i
    
    For i = 2 To UBound(a)
        If a(i, 4) <> .Item(CStr(a(i, 3))) Then MsgBox "Не сходится по дог. " & _
        a(i, 3) & ": " & a(i, 4) & " и " & .Item(CStr(a(i, 3))), 64
    Next i
    Range("G8").Resize(.Count).Value = Application.Transpose(.items)
End With
End Sub