Sub asd()
    Dim delrows As New Collection
    key_words = Array("Апельсин", "Большой мандарин")
    col = 4
    For i = 4 To Cells(Rows.Count, 4).End(xlUp).Row
        If Not IsEmpty(Cells(i, col)) Then
            If col = 3 Then col = 4
            For j = 0 To UBound(key_words)
                If key_words(j) = Cells(i, col) Then
                    col = 3
                    Exit For
                End If
            Next j
        ElseIf col = 3 Then
            delrows.Add (i)
        End If
    Next i
    
    For i = delrows.Count To 1 Step -1
        Rows(delrows.Item(i)).Delete
    Next i
End Sub

Sub asd()
    For i = 7 To Cells(Rows.Count, 5).End(xlUp).Row
        If Range("E" & i).MergeCells Then
            Set tng = Range("E" & i).MergeArea
            tng.UnMerge
            For j = tng.Cells(1, 1).Row To tng.Cells(1, 1).Row + tng.Rows.Count - 1
                Cells(j, "E") = tng.Cells(1, 1).Value
            Next j
        End If
    Next i
End Sub

For i = 1 To UBound(ar1)
    ar2(i * 2, 1) = ar1(i, 1)
    ar2(i * 2 - 1, 1) = ar1(i, 1)
Next i

Sub Formulas_To_Values_Selection()
    For Each Row In Selection.Rows
        If Row.Cells(1, 1) <> "" Then
            Range(Row.Address) = Range(Row.Address).Value
        End If
    Next
End Sub

<div +class="[a-z_]+">

Sub asd()
    ReDim arr(0)
    For Each st In Sheets
        If st.Visible = True Then
            arr(UBound(arr)) = st.Name
            ReDim Preserve arr(UBound(arr) + 1)
        End If
    Next
    ReDim Preserve arr(UBound(arr) - 1)
    Sheets(arr).Select
End Sub

Sub DoTrans()

  Set cn = CreateObject("ADODB.Connection")
  dbPath = "C:\**s\Database1.accdb"
  dbWb = Application.ActiveWorkbook.FullName
  dbWs = Application.ActiveSheet.Name
  scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
  dsh = "[" & Application.ActiveSheet.Name & "$]"
  cn.Open scn

  ssql = "INSERT INTO table1 SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh

  cn.Execute ssql

End Sub

               <DIV  id=$PpyListViewContentPage$ppxResults$l2$pWork_StatusTitleEr­ror  class=iconErrorDiv style="DISPLAY: none">
                  <SPAN title=""  class=iconError errId=""></SPAN>
               </DIV>
               Передан  
            </SPAN>
         </TD>
         </TR>
      </TBODY>
   </TABLE>
</DIV>

Sub asd()
    For i = 2 To Sheets.Count
        For Each cell In Sheets(i).UsedRange.Columns(1).Cells
            If cell.Value <> i - 1 Then
                cell.EntireRow.Hidden = True
            End If
        Next
    Next i
End Sub

Sub asd()
    Dim c As New Collection
    
    c.Add 2, "Лист1"
    c.Add 3, "Лист2"
    
    For Each st In ActiveWorkbook.Sheets
        For Each cell In st.UsedRange.Columns(1).Cells
            If cell.Value = c.Item(st.Name) Then cell.EntireRow.Hidden = True
        Next
    Next
End Sub

Sub asd()
    f_sn = Range("A2:B5")
    s_sn = Range("D2:E5")
    
    For i = 1 To UBound(f_sn, 1)
        For j = 1 To UBound(s_sn, 1)
            If f_sn(i, 1) = s_sn(j, 1) Then
                f_sn(i, 2) = s_sn(j, 2)
                Exit For
            End If
        Next j
    Next i
    
    Cells(2, 1).Resize(UBound(f_sn, 1), UBound(f_sn, 2)) = f_sn
End Sub

Sub asd()
    m = CDate(InputBox("Date"))
    
    ReDim arr(0 To 1, 0 To 1)
    
    i = 0
    For d = DateSerial(Year(m), Month(m), 1) To DateSerial(Year(m), Month(m) + 1, 0)
        If Weekday(d, 2) = 1 Then
            arr(0, i) = d
        ElseIf Weekday(d, 2) = 7 Then
            arr(1, i) = d
            If arr(1, i) <> DateSerial(Year(m), Month(m) + 1, 0) Then
                i = i + 1
                ReDim Preserve arr(1, i)
            End If
        End If
    Next
    
    If IsEmpty(arr(0, 0)) Then
        arr(0, 0) = DateSerial(Year(m), Month(m), 1)
    End If
    
    If IsEmpty(arr(1, i)) Then
        arr(1, i) = DateSerial(Year(m), Month(m) + 1, 0)
    End If
    
    
    Cells(1, 1).Resize(UBound(arr, 2) + 1, 2) = Application.Transpose(arr)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Range("B2:Y100"), Target) Is Nothing Then
        Range(Target.Address).ClearComments
        Range(Target.Address).AddComment Sheets(2).Range(Target.Address).Text
    End If
End Sub

ReDim arr(1 To 1, 1 To 31)

For i = 1 To 31
    If Not Cells(1, i).Comment Is Nothing Then
        arr(1, i) = Cells(1, i).Comment.Text
    End If
Next i

Sub asd()
    act = MsgBox("Вы действительно хотите обновить данные?", vbYesNoCancel, "Обновление данных")
    If act = vbYes Then
        MsgBox "Yes"
    End If
End Sub