Sub Êíîïêà4_Ùåë÷îê()
For Each i In ThisWorkbook.Worksheets("Ëèñò1").UsedRange
    If i.Interior.Color = 15773696 Then i.Value = "Ñëîâî"
Next i
End Sub

Sub Кнопка4_Щелчок()
For Each i In ThisWorkbook.Worksheets("Лист1").UsedRange
    If i.Interior.Color <> xlNone And i.Interior.Color <> 16777215 Then i.Value = "Слово"
Next i
End Sub

Private Sub CommandButton1_Click()
Sheets("Лист1").[A3] = Me.TextBox1
Sheets("Лист1").[B5] = Me.TextBox2
End Sub

If Target.Cells.Count > 1 Then Exit Sub

If Cells(i, "F:F") = "" Then Invoice_Report : Exit Sub

Sub РазбиениеПоСимволам()
Dim LastRow As Long, i As Long, Arr(), Arr3, Arr10, x3 As Long, x10 As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Arr = Range(Cells(5, 1), Cells(LastRow, 1)).Value
    ReDim Arr3(1 To UBound(Arr), 1 To 1)
    ReDim Arr10(1 To UBound(Arr), 1 To 1)
    For i = 1 To UBound(Arr)
        If Len(Arr(i, 1)) <= 4 Then
            x3 = x3 + 1
            Arr3(x3, 1) = Arr(i, 1)
        Else
            x10 = x10 + 1
            Arr10(x10, 1) = Arr(i, 1)
        End If
    Next
    Range("B5").Resize(x3, 1).Value = Arr3
    Range("C5").Resize(x10, 1).Value = Arr10
End Sub

Sub ПоискКоординатСкопления()
Dim x, n, nMax As Integer, ПредЗнач, КоорНач, КорН, КорК, Знач As Variant
For Each x In Range(Cells(3, "D"), Cells(Cells(80000, "D").End(xlUp).Row, "D"))
    If x.Value <> ПредЗнач Then n = 1: КоорНач = x.Offset(0, -1).Value: КоорКон = КоорНач
    If x.Value = ПредЗнач Then n = n + 1: КоорКон = x.Offset(0, -1).Value
    ПредЗнач = x.Value
If n > nMax Then nMax = n: Знач = x.Value: КорН = КоорНач: КорК = КоорКон
Next x
[F2] = Знач
[G2] = КорН & "-" & КорК
End Sub

Sub УдалитьСтроки()
Сегодня = CDate(Trim(Left(Now, InStr(Now, " "))))
m = ActiveSheet.UsedRange.Rows.Count
For i = 1 To m
If Cells(i, 4) < Сегодня And IsEmpty(Cells(i, 4)) = False Then Rows(i).Delete: m = m - 1: i = 0
Next i
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[c8] = [B6]
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If [C1]=1 then
  тело макроса
end if
end sub

Sub Проба1()
конец = Sheets("БД").Cells(500000, 1).End(xlUp).Row
For Each i In Range(Sheets("БД").Cells(2, 2), Sheets("БД").Cells(конец, 2))
    Геозона = i.Value
    For Each Вкладки In ThisWorkbook.Sheets
        If Геозона = Вкладки.Name Then
            With ThisWorkbook.Sheets(Геозона)
            конецГеозона = .Cells(500000, 1).End(xlUp).Row + 1
            y = i.Offset(0, -1)
            .Cells(конецГеозона, 1) = i.Offset(0, -1)
            .Cells(конецГеозона, 2) = i
            .Cells(конецГеозона, 3) = i.Offset(0, 1)
            .Cells(конецГеозона, 4) = i.Offset(0, 2)
            'Занесите сюда все столбцы по образу и подобию как показано
            
            End With
        End If
    Next Вкладки
Next i
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Строка = InputBox("Введите номер строки для перехода", "Переход", 0)
If Строка = Empty Then Exit Sub
ActiveWindow.ScrollRow = CCur(Строка) + 12
ActiveWindow.ScrollColumn = 1
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count = 1 Then
    If Not Intersect(Target, [h10:H11,L10:L11]) Is Nothing Then    'адрес ячейки
        Application.EnableEvents = False
        UserForm1.Show
        Application.EnableEvents = True
    End If
End If
End Sub

Private t As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox t
t = Target.Address
End Sub