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

Sub HideRibbon()
    Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", False)"
    Call FitTable
End Sub

Sub ShowRibbon()
    Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", True)"
    DoEvents
    Call FitTable
End Sub
Sub FitTable()
    Range("B1").CurrentRegion.Select
    ActiveWindow.Zoom = True
    Range("B1").Select
End Sub

Sub Create()
    Dim i As Integer, sFolder As String, sFiles As String
    sFolder = "путь к папке"
    sFiles = Dir(sFolder & x & "extr_*")
    Do While sFiles <> ""
        Workbooks.Open sFolder & sFiles
        sFiles = Dir
        For i = 1 To Sheets.Count
            If Sheets(i).Name Like "extr_*" Then
                Sheets(i).Name = "Лист1"
            End If
        Next i
        ActiveWorkbook.Close SaveChanges:=True
    Loop
End Sub

For i = 2 To 98 Step 6

ActiveWindow.ScrollColumn = ...

Columns("N:Y").EntireColumn.Hidden = False

Range("X2").Copy' И дальше аналогично без Select и Selection
Range("X2").PasteSpecial Paste:=xlPasteValues '...