Sub СуммВыделенЧис()
If TypeName(Selection) <> "Range" Then Exit Sub

Total = 0
Total = Application.Sum(Selection.SpecialCells(xlCellTypeVisible))
Total = Replace(Total, ",", ".")

With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Total
.PutInClipboard
End With

Application.StatusBar = "Сумма активных ячеек = " & Trim(Format(Total, "### ### ### ### ### ##0.000")) & " значение помещено в буфер обмена"
End Sub

Sub Выделение_цветом_машин_для_сводки()
Dim rFndRng As Range, x
  For Each x In Array("VOLVO В 210 СС 73", "10", "50", "95", "5", "143", "660", "470")
    Set rFndRng = Cells.Find(x, , xlValues, xlWhole)
    If Not rFndRng Is Nothing Then rFndRng.Interior.Color = vbRed
  Next
End Sub

 Private Sub Worksheet_Change(ByVal Target As Range) 
Dim x 
Application.EnableEvents = False 
On Error Resume Next 
For Each x In Target 
If VarType(x.Value) = vbString Then 
' If VarType(Evaluate(x.Value)) <> vbError Then 
If x.NumberFormat = "@" Then x.NumberFormat = "General" 
x.FormulaLocal = "=" & x.Value 
If Err Then 
x.Formula = "=" & x.Value 
Err.Clear 
End If 
' End If 
End If 
Next 
Application.EnableEvents = True 
End Sub 

Sub Макрос1()'
    Dim rFndRng As Range
    Set rFndRng = Rows(200).Find("618", , xlValues, xlWhole)
    If rFndRng Is Nothing Then
        MsgBox "Нет такого"
    Else
        rFndRng.Select
    End If

  
End Sub

Private Sub Worksheet_Activate()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim i As Integer
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A4:G" & iLastRow).ClearContents
For Each Sht In Worksheets
If Sht.Name <> "Ñâîäíàÿ" And Sht.Name <> "Òàáë" And Sht.Name <> "Äàííûå" And Sht.Name <> "ØÀÁËÎÍ" And Sht.Name <> "Ñïðàâêà" Then
' êðîìå ëèñòà "Ñâîäíàÿ" Òàáë è Äàííûå
With Sht
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1

.Range("D7").Copy
Cells(iLastRow, 3).PasteSpecial xlPasteValuesAndNumberFormats
Cells(iLastRow, 1) = Sht.Name
Range(Cells(iLastRow, 1), Cells(iLastRow + 6, 1)).FillDown

.Range("C26:C32").Copy
Cells(iLastRow, 4).PasteSpecial xlPasteValuesAndNumberFormats

.Range("D26:D32").Copy
Cells(iLastRow, 5).PasteSpecial xlPasteValuesAndNumberFormats

.Range("F26:F32").Copy
Cells(iLastRow, 6).PasteSpecial xlPasteValuesAndNumberFormats



End With
End If
Next
End Sub