Sub DeleteMergedRows()
    Dim myRange As Range
    Set myRange = Range("A100:A124")
    myRange.EntireRow.Hidden = False
    myRange.UnMerge
    myRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlShiftUp
End Sub

'назовём её lastRow
lastRow = Cells(Rows.Count, "AD").End(xlUp).Row + 1

Sub CopyPictures()
    Dim lastRow As Long, i As Long, pathBase As String, pathDestination As String
    Dim strFile As String
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    pathBase = ThisWorkbook.Path & "\Номер карты\"
    pathDestination = ThisWorkbook.Path & "\Табельный номер\"
    For i = 2 To lastRow
        strFile = pathBase & Cells(i, 2).Value & ".jpg"
        If Dir(strFile) <> "" Then
            FileCopy pathBase & Cells(i, 2).Value & ".jpg", pathDestination & Cells(i, 10).Value & ".jpg"
            Cells(i, 11).Value = "V"
            Cells(i, 11).Font.Color = vbGreen
        Else
            Cells(i, 11).Value = "нет файла"
            Cells(i, 11).Font.Color = vbRed
        End If
    Next i
End Sub

Sub checkValidation()
    Dim cell As Range, v As Long
    For Each cell In Selection.Cells
        v = 0
        On Error Resume Next
        v = cell.SpecialCells(xlCellTypeSameValidation).Count
        On Error GoTo 0
        If v = 0 Then
            Debug.Print cell.Address & ": no validation"
        Else
            Debug.Print cell.Address & ": has validation"
        End If
    Next
End Sub

ActiveSheet.Hyperlinks.Delete

Sub Insert_tab3_1()
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, 2).Value = Range("J32").Value
End Sub
Sub Clear_Insert_tab3_1()
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Value = ""
End Sub

Sub DeleteRows()
    Dim lastRow As Long, i As Long
    Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lastRow To 1 Step -1
        If Cells(i, 1).Value = "x" Then Cells(i, 1).EntireRow.Delete Shift:=xlShiftUp
    Next i
End Sub

If cell.Value = "x" Then cell.EntireRow.Delete Shift:=xlShiftUp

Sub UnMergeAndFillCells()
    Dim cell As Range, tempRange As Range, firstCellAddress As String
    Application.ScreenUpdating = False
    For Each cell In ActiveSheet.UsedRange.Cells
        If cell.MergeCells And cell.MergeArea.Columns.Count = 1 Then
            firstCellAddress = cell.Address(0, 0)
            Set tempRange = cell.MergeArea
            cell.UnMerge
            Range(firstCellAddress).AutoFill Destination:=tempRange, Type:=xlFillCopy
        ElseIf cell.MergeCells And cell.MergeArea.Columns.Count > 1 Then
            cell.UnMerge
            cell.WrapText = False
            If Not IsNumeric(cell.Value) Then
                cell.HorizontalAlignment = xlLeft
            End If
        End If
    Next cell
End Sub

Sub UnMergeAndFillCells()
    Dim cell As Range, tempRange As Range, firstCellAddress As String
    Application.ScreenUpdating = False
    For Each cell In ActiveSheet.UsedRange.Cells
        If cell.MergeCells And cell.MergeArea.Columns.Count = 1 Then
            firstCellAddress = cell.Address(0, 0)
            Set tempRange = cell.MergeArea
            cell.UnMerge
            Range(firstCellAddress).AutoFill Destination:=tempRange
        End If
    Next cell
End Sub

Sub CopyTable()
    Dim wbSource As Workbook, wbDestination As Workbook
    Dim myTable As Range, myNewTable As Range, Cell As Range
    
    Application.ScreenUpdating = False
    
    Set wbSource = ThisWorkbook
    Set myTable = wbSource.Worksheets(1).Range("A2").CurrentRegion
    Set wbDestination = Workbooks.Add
    
    myTable.Copy
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteFormats
    
    Set myNewTable = wbDestination.Worksheets(1).Range("A2").CurrentRegion
    
    For Each Cell In myTable
        myNewTable.Range(Cell.Address).Interior.Color = Cell.DisplayFormat.Interior.Color
    Next Cell
    myNewTable.Cells(1, 1).Select
    Application.CutCopyMode = False
End Sub

Sub CopyTable()
    Dim wbSource As Workbook, wbDestination As Workbook
    Dim myTable As Range, myNewTable As Range, Cell As Range
    
    Application.ScreenUpdating = False
    
    Set wbSource = Workbooks("Так есть.xlsx")
    Set myTable = wbSource.Worksheets(1).Range("A2").CurrentRegion
    Set wbDestination = Workbooks("Destination Book.xlsm")
    
    myTable.Copy
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
    wbDestination.Worksheets(1).Range("A1").PasteSpecial xlPasteFormats
    
    Set myNewTable = wbDestination.Worksheets(1).Range("A2").CurrentRegion
    
    For Each Cell In myTable
        myNewTable.Range(Cell.Address).Interior.Color = Cell.DisplayFormat.Interior.Color
    Next Cell
    myNewTable.Cells(1, 1).Select
    Application.CutCopyMode = False
End Sub