Private Sub Worksheet_Change(ByVal Target As Range)
With Sheets("На участке")
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [e:e]) Is Nothing And IsDate(Target.Value) Then 
        .Rows(Target.Row).Copy Sheets("Отгружены").Rows(WorksheetFunction.CountA(Sheets("Отгружены").[a:a]) + 1)
        .Rows(Target.Row).Delete
    End If
End With
End Sub

Sub csg()
Dim FoundCell As Range, txt As Variant, FAdr As String
txt = Range("B17").Value
Set FoundCell = Range("G:G").Find(txt, , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
       Do
         Range(Cells(FoundCell.Row, 7), Cells(FoundCell.Row, 19)).ClearContents
        'Range(Cells(FoundCell.Row, 7), Cells(FoundCell.Row, 19)).Delete Shift:=xlUp 'если нужно удалить со сдвигом вверх
         Set FoundCell = Range("G:G").FindNext
        Loop While Not FoundCell Is Nothing
    End If
End Sub

Sub мкр3()
  With Worksheets("Лист2")
    Range("J9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Copy
    .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
  End With
End Sub

Sub csg()
Dim tt As Integer
Dim i As Long, j As Long, n As Long
Dim sh As Worksheet
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 Set sh = Sheets("исходные_данные (2)")
 For i = 3 To 7
    For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row
        For n = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(j, i) = "" Then
                If Cells(j, 1) = sh.Cells(n, 3) And Cells(2, i) = sh.Cells(n, 8) Then tt = tt + 1
            End If
        Next
          Cells(j, i) = tt
          tt = 0
     Next
 Next
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic '
End Sub

=ЕСЛИ(ИЛИ(A1="да";A1="нет");"";C1)

Sub Macros()
  ActiveCell = "Текст"
  ActiveCell.Offset(1).Select
  End Sub

Sub ПереносСтрок()
Dim r As Range, lr As Long
lr = Cells(Rows.Count, 15).End(xlUp).Row
For Each r In Range(Cells(3, 15), Cells(lr, 15))
  If r = "Назначена встреча" Then
    Rows(r.Row).Copy Sheets("Результат").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Rows(r.Row).Delete
  End If
Next
End Sub

For i = lr To 2 Step -1 

Sub csg()
Dim myRange1 As Range, myRange2 As Range, myRange3 As Range
 Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim iCell As Range, mCell As Range
Dim i1&, i2&, c1&, c2&, j1&, j2&, n1&, n2&, k1&, k2&
On Error GoTo Inform
 Set myRange1 = Application.InputBox("Укажите первый диапазон:", "Выбор", Type:=8)
 Set Ws1 = myRange1.Worksheet
  i1 = myRange1.Row:  i2 = myRange1(myRange1.Count).Row
  c1 = myRange1.Column: c2 = myRange1(myRange1.Count).Column
 Set myRange2 = Application.InputBox("Укажите второй диапазон:", "Выбор", Type:=8)
 Set Ws2 = myRange2.Worksheet
  j1 = myRange2.Row:  j2 = myRange2(myRange2.Count).Row
  n1 = myRange2.Column:  n2 = myRange2(myRange2.Count).Column
 Set myRange3 = Application.InputBox("Укажите ячейку для вставки:", "Выбор", Type:=8)
 Set Ws3 = myRange3.Worksheet
  k1 = myRange3.Row:  k2 = myRange3.Column
 For Each iCell In Ws1.Range(Ws1.Cells(i1, c1), Ws1.Cells(i2, c1))
        For Each mCell In Ws2.Range(Ws2.Cells(j1, n1), Ws2.Cells(j2, n1))
            If iCell <> "" Then
                Ws1.Range(Ws1.Cells(iCell.Row, c1), Ws1.Cells(iCell.Row, c2)).Copy Ws3.Cells(k1, k2)
                Ws2.Range(Ws2.Cells(mCell.Row, n1), Ws2.Cells(mCell.Row, n2)).Copy Ws3.Cells(k1, k2).Offset(0, c2 - c1 + 1)
                k1 = k1 + 1
            End If
        Next
    Next
    Ws3.Activate
    Exit Sub
Inform:
MsgBox "Диалог закрыт или нажата кнопка " _
& Chr(34) & "Отмена" & Chr(34) & "!"
Exit Sub
End Sub

Private Sub Paste()
Range("A1").Select
Rows(ActiveCell.Row).Offset(1).Resize(30).ClearContents
Range("A1").Select
ActiveSheet.Paste
 End Sub

Sub csg()
Dim iCell As Range, mCell As Range
Application.ScreenUpdating = False
    For Each iCell In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
        For Each mCell In Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
            If iCell <> "" Then
                If iCell = mCell And iCell.Offset(0, 4) = mCell.Offset(0, -4) Then
                    Rows(mCell.Row).Delete
                End If
            End If
        Next
    Next
Application.ScreenUpdating = True
End Sub

Set fcell = Columns("A:A").Find(1510)
Rows(fcell.Row).Offset(1).Resize(n).Insert ' n- количество вставляемых строк

Sub csg()
Dim iCell As Range, mCell As Range, FreeRow As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 11).End(xlUp).Row
If lr < 3 Then lr = 3
Range("K3:P" & lr).ClearContents
FreeRow = 3
    For Each iCell In Range(Cells(3, "A"), Cells(Rows.Count, "A").End(xlUp))
        For Each mCell In Range(Cells(3, "E"), Cells(Rows.Count, "E").End(xlUp))
            If iCell <> "" Then
                Range(Cells(iCell.Row, 1), Cells(iCell.Row, 2)).Copy Cells(FreeRow, 11)
                Range(Cells(mCell.Row, 5), Cells(mCell.Row, 8).Copy Cells(FreeRow, 13)
                FreeRow = FreeRow + 1
            End If
        Next
    Next
Application.ScreenUpdating = True
End Sub

Sub ПроцедурыЯчейки()
Dim tt As Integer
Dim i As Long, j As Long, n As Long
Dim Rng As Range, x As Range
Static Txt As String
  Set Rng = Range("A1:U1")
  Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
  If Txt = "" Then Exit Sub
  Set x = Rng.Find(what:=Txt)
    With Sheets(Txt)
      For i = 2 To 12
        For j = 2 To 25
          If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then
             For n = 11 To 41
                If Sheets(Txt).Cells(j, n) <> 0 Then tt = tt + 1
             Next
            End If
         Next
            If tt <> 0 Then
            Cells(i, x.Column) = tt
            tt = 0
          End If
      Next
    End With
End Sub

Sub Пациенты()
Dim tt As Integer
Dim i As Long, j As Long
Dim Rng As Range, x As Range
Static Txt As String
  Set Rng = Range("A1:U1")
  Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
  If Txt = "" Then Exit Sub
  Set x = Rng.Find(what:=Txt)
  For i = 2 To 12
     For j = 2 To 25
        If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then tt = tt + 1
     Next
          If tt <> 0 Then
          Cells(i, x.Column) = tt
          tt = 0
       End If
   Next
End Sub

Sub Процедуры()
Dim tt As Single
Dim i As Long, j As Long
Dim Rng As Range, x As Range
Static Txt As String
  Set Rng = Range("A1:U1")
  Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
  If Txt = "" Then Exit Sub
  Set x = Rng.Find(what:=Txt)
    With Sheets(Txt)
      For i = 2 To 12
        For j = 2 To 25
          If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then tt = tt + Application.Sum(.Range(.Cells(j, 11), .Cells(j, 41)))
        Next
            If tt <> 0 Then
            Cells(i, x.Column) = tt
            tt = 0
          End If
      Next
    End With
End Sub

Sub csg()
Dim myName
Dim iCell As Range
Dim ws1 As Worksheet
Dim ws As Worksheet
Set ws1 = Sheet1
  For Each iCell In Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
    myName = iCell
    On Error Resume Next
    If Sheets(myName) Is Nothing Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = myName
        Set ws = ActiveSheet
        ws.Cells(1, 1) = myName
        Range(ws1.Cells(1, 1), ws1.Cells(1, 5)).Copy ws.Cells(2, 1)
        Range(ws1.Cells(iCell.Row, 1), ws1.Cells(iCell.Row, 5)).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Else
        Range(ws1.Cells(iCell.Row, 1), ws1.Cells(iCell.Row, 5)).Copy Sheets(myName).Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End If
  Next
End Sub

Range(.Cells(4, 1), .Cells(13, 7)).Copy Cells(RW, 1)

Range(.Cells(4, 1), .Cells(13, 7)).Copy
Cells(RW, 1).PasteSpecial Paste:=xlPasteValues

Sub СкрытьСтроки()
Application.ScreenUpdating = False
 Dim c As Range, LRow As Long, a As Variant, iCell As Range
LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range(Cells(3, 122), Cells(LRow, 122))
  If c = 0 Then
      a = c.Offset(0, -119).Value
      Set iCell = Range(Cells(2, 3), Cells(LRow, 3)).Find(a)
      Rows(iCell.Row).Resize(4).EntireRow.Hidden = True
   End If
Next
Application.ScreenUpdating = True
End Sub

Sub Скрыть_Строки()
 Application.ScreenUpdating = False
 Dim c As Range, LRow As Long
 LRow = Cells(Rows.Count, 1).End(xlUp).Row
    For Each c In Range(Cells(3, 22), Cells(LRow, 22))
      If c = 0 Then
        c.EntireRow.Hidden = True
      End If
    Next
 Application.ScreenUpdating = True
End Sub

Sub Скрыть_Столбцы()
 Application.ScreenUpdating = False
 Dim c As Range, lCol As Long
 lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    For Each c In Range(Cells(1, 5), Cells(1, lCol))
      If c = 0 Then
        c.EntireColumn.Hidden = True
      End If
    Next
 Application.ScreenUpdating = True
End Sub

Sub Макрос1()
Dim lr As Long, i As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For i = lr To 2 Step -1
  If Cells(i, 2) = "" Then
    Cells(i - 1, 1) = Cells(i - 1, 1) & Cells(i, 1)
    Rows(i).Delete
  End If
Next
End Sub