Private Sub Worksheet_Deactivate()
   Worksheets("Лист3").Visible = False
End Sub

Sub iHiddenSheet()
  Worksheets("" & Range("G4") & "").Visible = True
End Sub

Sub FindNomer()
Dim cell As Range
Dim Nomer As Long
   Nomer = Application.InputBox("Введите номер", Type:=1)
     Set cell = Columns(2).Find(Nomer, , xlValues, xlWhole)
        If Not cell Is Nothing Then
          cell.Interior.ColorIndex = 6
        Else
          MsgBox "В столбце В нет номера: " & Nomer
        End If
End Sub

как можно реализовать функцию суммеслимн в Excel 2003

Sub tt()
Dim i As Long
Dim iLastRow As Long
Dim FoundK As Range
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 43 To iLastRow
    Set FoundK = Range("A3:N38").Find(Cells(i, "A"), , xlValues, xlWhole)
      Cells(i, "B") = FoundK.Offset(-2)
  Next
End Sub

Sub iBorders()
Dim rng As Range
  For Each rng In Range("D4:J4")
    If rng.Borders(xlEdgeTop).LineStyle = xlContinuous And rng.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
      rng.Interior.ColorIndex = 8
    End If
  Next
End Sub

Sub iArticle()
Dim iLastRow As Long
Dim i As Long
Dim Article As String
Dim FoundArticle As Range
Dim FirstAdres As String
Dim j As Integer
  iLastRow = Cells(Rows.Count, "G").End(xlUp).Row
  Range("G4:H" & iLastRow).Interior.ColorIndex = xlNone
'  iLastRow = Cells(Rows.Count, "J").End(xlUp).Row
  For i = 3 To 7
    Article = Cells(i, "J")
Set FoundArticle = Columns(7).Find(Article, , xlValues, xlWhole)
    If Not FoundArticle Is Nothing Then     'нашли
        FirstAdres = FoundArticle.Address   'адрес первого вхождения
        Do
          For j = 11 To 14
            If FoundArticle.Offset(, 1) = CStr(Cells(i, j)) Then
              FoundArticle.Resize(, 2).Interior.ColorIndex = 6
              Exit For
            End If
          Next
            Set FoundArticle = Columns(7).FindNext(FoundArticle)
        Loop While FoundArticle.Address <> FirstAdres
    End If
  Next
End Sub

Range("F5").CurrentRegion.Select

Sub Schar()
Dim rng As Range
  For Each rng In Range("D4:K5")
    If WorksheetFunction.IsText(rng) And Not rng = "Шар" Then
      rng.Offset(1).Borders(xlEdgeLeft).Weight = xlThin
    End If
  Next
End Sub

Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "(ул\.|улица|пр\.)\s([^,]+)"
     If .test(cell) Then
       iStreet = .Execute(cell)(0).SubMatches(1)
     Else
       .Pattern = "([^,]+)(?=ул\.|тракт|пр\.)"
       iStreet = .Execute(cell)(0)
     End If
 End With
End Function

Sub Tablica()
Dim i As Long
Dim j As Integer
Dim n As Integer
Dim iLastRow As Long
Dim iCol As Integer              'количество необходимых столбцов
Dim k As Integer                 'кол-во столбцов с Range("P6")
Dim iLR As Long
Dim iLastCol As Integer
  iLR = Cells(Rows.Count, "A").End(xlUp).Row
  iLastCol = Cells(4, Columns.Count).End(xlToLeft).Column
    Range(Cells(4, 1), Cells(iLR, iLastCol)).ClearContents
  iLastRow = Cells(Rows.Count, "O").End(xlUp).Row
  iCol = WorksheetFunction.RoundUp((iLastRow - 5) / Range("P6"), 0)
  If iCol >= 15 Then MsgBox "При таком количестве строк данные будут затерты": Exit Sub
   For n = Range("P6") - 1 To 1 Step -1
      k = 0
    Do
      k = k + 1
    Loop While k * Range("P6") + (iCol - k) * n <> iLastRow - 5 And k < iCol
      If k * Range("P6") + (iCol - k) * n = iLastRow - 5 Then Exit For
   Next
    j = 1
  For i = 6 To k * Range("P6") + 5 Step Range("P6")
    Range(Cells(i, "O"), Cells(i + Range("P6") - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
  For i = k * Range("P6") + 6 To iLastRow Step n
    Range(Cells(i, "O"), Cells(i + n - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
End Sub

Sub Tablica()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim iCol As Integer              'количество необходимых столбцов
Dim k As Integer                 'кол-во столбцов с Range("P6")
  iLastRow = Cells(Rows.Count, "O").End(xlUp).Row
  iCol = WorksheetFunction.RoundUp((iLastRow - 5) / Range("P6"), 0)
  Range(Cells(4, 1), Cells(3 + Range("P6"), iCol)).ClearContents
    k = 0
  Do
    k = k + 1
  Loop While k * Range("P6") + (iCol - k) * (Range("P6") - 1) <> iLastRow - 5 Or k > iCol - 1
    j = 1
  For i = 6 To k * Range("P6") + 5 Step Range("P6")
    Range(Cells(i, "O"), Cells(i + Range("P6") - 1, "O")).Copy Cells(4, j)
    j = j + 1
  Next
  For i = k * Range("P6") + 6 To iLastRow - 5 Step Range("P6") - 1
    Range(Cells(i, "O"), Cells(i + Range("P6") - 2, "O")).Copy Cells(4, j)
    j = j + 1
  Next
End Sub

Sub GroupNapravlenie()
Dim iLastRow As Long
Dim Found_N As Range
Dim FAdr As String
 Application.ScreenUpdating = False
 With Worksheets("Report1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B2:M" & iLastRow).ClearContents
  For i = 2 To iLastRow
   Set Found_N = .Columns("I").Find(Cells(i, "A"), , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
      FAdr = Found_N.Address
      Do
        Select Case Found_N.Offset(, -7)
         Case "1"
           Cells(i, "B") = Cells(i, "B") + 1
         Case "3"
           Cells(i, "C") = Cells(i, "C") + 1
         Case "11"
           Cells(i, "D") = Cells(i, "D") + 1
         Case "12"
           Cells(i, "E") = Cells(i, "E") + 1
         Case "15"
           Cells(i, "F") = Cells(i, "F") + 1
         Case "18"
           Cells(i, "G") = Cells(i, "G") + 1
         Case "20"
           Cells(i, "H") = Cells(i, "H") + 1
         Case "26"
           Cells(i, "I") = Cells(i, "I") + 1
         Case "29"
           Cells(i, "J") = Cells(i, "J") + 1
         Case "30"
           Cells(i, "K") = Cells(i, "K") + 1
         Case "31"
           Cells(i, "L") = Cells(i, "L") + 1
         Case "37"
           Cells(i, "M") = Cells(i, "M") + 1
        End Select
          Set Found_N = .Columns("I").FindNext(Found_N)
      Loop While Found_N.Address <> FAdr
    End If
  Next
 End With
 Application.ScreenUpdating = True
End Sub

Sub PoiskTelefonAndDeleteRows()
Dim Found_N As Range
Dim i As Long
Dim iLR As Long
Dim Found_Itogo As Range
With Worksheets("Лист3")
 iLR = .Cells(.Rows.Count, "A").End(xlUp).Row
  For i = 1 To iLR
   Set Found_N = Columns("B").Find(.Cells(i, "A"), , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
        Set Found_Itogo = Cells(Found_N.Row, "A").End(xlDown)
        Rows(Found_N.Row & ":" & Found_Itogo.Row).Delete
    End If
  Next
End With
End Sub

Sub PoiskTelefon()
Dim Found_N As Range
Dim Found_Itogo As Range
Dim FAdr As String
  Set Found_N = Columns("B").Find("375291112233", , xlValues, xlWhole)
    If Not Found_N Is Nothing Then
        Set Found_Itogo = Cells(Found_N.Row, "A").End(xlDown)
        Rows(Found_N.Row & ":" & Found_Itogo.Row).Delete
    End If
End Sub

Function iFIO(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[А-ЯЁ]\.[А-ЯЁ]\. [А-ЯЁ][а-яё]+"
     If .test(cell) Then
       iFIO = .Execute(cell)(0)
     End If
 End With
End Function

Function iVolume(cell$)
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "(\d+)н?-(\d+)н?-(\d+)"
    If .test(cell) Then
     iVolume = .Execute(cell)(0).SubMatches(0) * .Execute(cell)(0).SubMatches(1) * _
               .Execute(cell)(0).SubMatches(2) * 30 / 10000
     .Pattern = "\d+(?=\s?шт)"
     If .test(cell) Then
       iVolume = iVolume * .Execute(cell)(0)
     End If
    End If
 End With
End Function