Option Explicit

Sub InsertRow_2()
    Dim r&: r = 2
    Dim rws&: rws = Range("a1").CurrentRegion.Rows.Count
    Dim col%: col = Range("a1").CurrentRegion.Columns.Count
    Dim zaglwk(): zaglwk = Range("a1").Resize(1, col).Value
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Do While r < rws
        If Cells(r, 1).Value <> "" Then
            If Cells(r + 1, 1).Value <> Cells(r, 1).Value Then
                Rows(r + 1).Insert Shift:=xlDown
                Cells(r + 1, 1).Resize(1, col).Value = zaglwk
                rws = rws + 1
                r = r + 1
            End If
        End If
        r = r + 1
    Loop
    Erase zaglwk
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Option Explicit

Sub InsertRow_1()
    Dim r&: r = 1
    Dim rws&: rws = Selection.Rows.Count
    Do While r < rws
        If Trim(Cells(r, 1).Value) <> "" Then
            If Cells(r, 1).Offset(1, 0).Value <> Cells(r, 1).Offset(0, 0).Value Then
                Rows(1).Copy
                Cells(r, 1).Offset(1, 0).Insert
                Application.CutCopyMode = False
                Selection.Resize(rws + 1).Select 'это не обязательно
                rws = rws + 1
                r = r + 1
            End If
        End If
        r = r + 1
    Loop
End Sub

Private Sub lbList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim i As Long
    With lbList
        i = .ListIndex: If i = -1 Then Exit Sub
        If .ListCount = 0 Then Cancel = True
        'rRng(i + 1).EntireColumn.Hidden = Not rRng(i + 1).EntireColumn.Hidden
        If Not .Selected(i) = Columns(i + 1).Hidden Then Columns(i + 1).Hidden = .Selected(i)
    End With
    ActiveWindow.SmallScroll ToRight:=-(i + 1)
End Sub

Sub Makro2()
    With Range("A1").CurrentRegion
        .Range("D1").FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
        .Range("D1", "D" & .Rows.Count).FillDown
    End With
    With Range("F1").CurrentRegion
        .Range("F1").FormulaR1C1 = "=CONCATENATE(RC[-5],RC[-4],RC[-3],RC[-2],RC[-1])"
        .Range("F1", "F" & .Rows.Count).FillDown
    End With
End Sub

    Const strPath$ = "C:\Temp\1.txt"
    Dim nmbr%, strfle$, s
    
    strfle = Dir(strPath, vbNormal)
    
    If strfle <> "" Then
        nmbr = FreeFile(0)
        Open strPath For Input Access Read Lock Read As #nmbr
        s = Input(LOF(nmbr), #nmbr)
        Close #nmbr
        
        s = Trim(s)
        Do While Right(s, 2) = vbCrLf
            s = Left(s, Len(s) - 2)
        Loop
        s = Trim(s)
        
        'i daleye
        ' ...
    End If

Option Explicit

Sub sverkhu_vniz()
    Const chyo = 1 'usloviye
    Dim r&: r = 5 'nachalo
    Do Until Trim(Cells(r, "a").Value) = ""
        If Cells(r, "i").Value = chyo Then Cells(r, "g").Value = Cells(r, "f").Value
        r = r + 1
    Loop
End Sub

Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
    
        For Each krtn In .Parent.Shapes
            Select Case krtn.Type
                Case msoLinkedPicture, msoPicture: If krtn.Name Like "Rys_*" Then krtn.Delete
                Case Else: 'Net
            End Select
        Next
        
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub

Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub

Sub Makros1()
    Range("a2").Select
    With Range("a2:e16")
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=A2="""""
        .FormatConditions(1).Interior.ColorIndex = 3
    End With
End Sub

Sub Makros2()
    With Range("a2:e16")
        .SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
    End With
End Sub

Option Explicit

Dim tbl()
Dim vybor$
Dim blokiruy As Boolean

Private Sub UserForm_Initialize()
    blokiruy = True
    With ThisWorkbook.Sheets("List1").Range("a1").CurrentRegion
        tbl = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    End With
    With UserForm1
        .Caption = "Okno"
        With .ComboBox1
            .List() = tbl
            .ListIndex = -1
        End With
        With .ListBox1
            .List() = tbl
            .ListIndex = -1
        End With
    End With
    blokiruy = False
End Sub

Private Sub ComboBox1_Change()
    If blokiruy Then Exit Sub
    With UserForm1
        vybor = .ComboBox1.Value
        With .ListBox1
            .Value = vybor
            .SetFocus
        End With
    End With
End Sub

Option Explicit

Sub bez_min_daty()
Dim r&, c%, i&, j%, k&, min_date, tbl_tmp(), tbl()
Dim tmr!: tmr = Timer

    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
        .EnableEvents = False: .Calculation = xlManual
    End With
    
    With Range("a1").CurrentRegion
        r = .Rows.Count - 1: c = .Columns.Count
        min_date = Application.Min(.Offset(1, 0).Resize(r, 1))
        tbl_tmp = .Offset(1, 0).Resize(r, c).Value
    End With
    
    For i = 1 To r
        If tbl_tmp(i, 1) <> min_date Then k = k + 1
    Next
    
    ReDim tbl(1 To k, 1 To c): k = 0
    
    For i = 1 To r
        If tbl_tmp(i, 1) <> min_date Then
            k = k + 1
            For j = 1 To c
                tbl(k, j) = tbl_tmp(i, j)
            Next
        End If
    Next
    
    Erase tbl_tmp
    
    With Range("a1").CurrentRegion.Offset(1, 0)
        .Resize(r, c).Clear: .Resize(k, c).Value = tbl
    End With
    
    Erase tbl
    
    With Application
        .Calculation = xlAutomatic: .EnableEvents = True
        .DisplayAlerts = True: .ScreenUpdating = True
    End With
    
    MsgBox "Ves' protsess prodolzhalsya: " & CStr(Round(Timer - tmr, 4)) & " s", vbOKOnly, "Info !"
End Sub

Option Explicit

Sub tablitsy()
Dim stroky As Long
Dim tbl
Dim objList As Worksheet

    For Each objList In ThisWorkbook.Worksheets
        If objList.Name <> "Svodnaya" Then
            tbl = objList.ListObjects.Item(1).DataBodyRange.Value
            With Sheets("Svodnaya").ListObjects.Item(1)
                stroky = .Range.Rows.Count
                If stroky > 2 Then stroky = stroky + 1
                'ili
                'On Error Resume Next
                '    stroky = .DataBodyRange.Rows.Count
                '    If Err.Number = 0 Then stroky = stroky + 2 Else stroky = 2
                'On Error GoTo 0
                .Range.Cells(stroky, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
                'ili
                '.Range(stroky, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
            End With
        End If
    Next
End Sub

Option Explicit

Sub macro_macro() 'Îáíîâëaíea_ëenoîâ_1() ' ?

    Const strFile$ = "\\Polymer2000\áaçu erp\Nëóaáa Ea÷anoâa\?AANO?U çaá?aeîâaííîé iîeóiíîé i?îäóeöee\" & _
                        "Ô-9-49 ?aano? çaá?aeîâaííîé iîeóiíîé i?îäóeöee ía ânao ýoaiao i?îeçâîänoâa.xlsm"
    
    Dim strCon$: strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    
    Dim strTableName: strTableName = Array("ÔIÔ", "CNBM", "Hydro", "3I", "Henkel", "8113", "AIOO-Eíâano", "Qindaî", _
                            "Shanghai", "Symetal", "Assan", "Effegidi", "Dong-Il", "Áeaeniëaí", "CarWare", _
                            "Flex", "N?? shur", "Petlar", "Jindal", "Tagleef", "Treofan", "N?? Flex")
    
    Dim rng: rng = Array("$A2:T500", "$A2:AD500", "$A2:AD500", "$A2:AD500", "$A2:AG500", "$A2:AH500", "$A2:AN500", "$A2:AN500", _
                            "$A2:AN500", "$A2:AN500", "$A2:AO500", "$A2:AO500", "$A2:AO500", "$A2:AP500", "$A2:AP500", _
                            "$A2:AP500", "$A2:AP500", "$A2:AP500", "$A2:AQ500", "$A2:AQ500", "$A2:AQ500", "$A2:AT500")
                            
    Dim strSQL1$, i&, indx&: indx = UBound(strTableName)
    
    Dim cn As ADODB.Connection: Set cn = CreateObject("ADODB.Connection")
    Dim rs As ADODB.Recordset: Set rs = CreateObject("ADODB.Recordset")
    
    Application.Calculation = xlManual
    Sheets("Iîaaëaíey-i?aäëîaaíey").Activate
    
    cn.Open strCon
    
    For i = 0 To indx
        strSQL1 = "SELECT * FROM [" & strTableName(i) & rng(i) & "]"
        rs.Open strSQL1, cn
        Worksheets(strTableName(i)).Range("A2").CopyFromRecordset rs
        rs.Close
    Next
    
    Set rs = Nothing
    cn.Close: Set cn = Nothing
    
    Application.Calculation = xlAutomatic

End Sub

Option Explicit

Sub a_b_c_v0()
Dim JachList1, JachList2
Dim indx As Long, i As Long, r As Long: r = 1
Dim shL1 As Worksheet: Set shL1 = ThisWorkbook.Sheets("List1")
Dim shL2 As Worksheet: Set shL2 = ThisWorkbook.Sheets("List2")

    If Trim(shL2.Cells(1, 1).Value) <> "" Then
        JachList2 = Split(shL2.Cells(1, 1).Value, ",", -1, 1)
        indx = UBound(JachList2)
        
        Do Until Trim(shL1.Cells(r, 1).Value) = ""
            JachList1 = Trim(CStr(shL1.Cells(r, 1).Value))
            
            For i = 0 To indx
                If JachList1 = Trim(CStr(JachList2(i))) Then Exit For
            Next
            
            If i > indx Then shL2.Cells(1, 1).Value = Trim(shL2.Cells(1, 1).Value) & "," & JachList1
            
            r = r + 1
        Loop
        
    End If
    
    Set shL1 = Nothing
    Set shL2 = Nothing
End Sub

Choose(DatePart("w", #8/19/2018#, vbMonday, vbFirstJan1), "Mo", "Tu", "We", "Th", "Fr", "Sa", "Su")

Option Explicit

Sub aaaaaa()
    Dim r As Integer: r = 1
    Do Until Trim(Sheets("СВОД").Cells(r, 1).Value) = ""
        ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count), Count:=1, Type:=xlWorksheet).Name = Trim(Sheets("СВОД").Cells(r, 1).Value)
        Range("a3").Value = Sheets("СВОД").Cells(r, 2).Value
        r = r + 1
    Loop
End Sub

ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Left(importWB.Name, Len(importWB.Name) - InStrRev(importWB.Name, ".", -1, 1) + 1)

Option Explicit
Option Private Module

Sub otkroy_kopiruy_zakroy()
Dim kngDostup As String, kngList As String, kngDiapazon As String, kngMestoKop As String
Dim tbl() As Variant
Dim istdann As Object

Const bazList As String = "List2"       'Nastroyki

    Application.ScreenUpdating = False
    
    With ThisWorkbook
        With .Sheets(bazList)
            kngDostup = .Range("A1").Value
            kngList = .Range("A2").Value
            kngDiapazon = .Range("A3").Value
            kngMestoKop = .Range("A4").Value
        End With
        
        Set istdann = GetObject(kngDostup)
        'Windows(istdann.Name).Visible = True
        tbl = istdann.Sheets(kngList).Range(kngDiapazon).Value
        istdann.Close SaveChanges:=False
        Set istdann = Nothing
        
        With .Sheets(kngMestoKop)
            With .Range("A1")
                .Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
                .CurrentRegion.EntireColumn.AutoFit
            End With
            Erase tbl
            .Activate
        End With
    End With
    
    Application.ScreenUpdating = True
End Sub

Sub Command_Com_Tor_b()
    'curr_row = ActiveCell.Row '?
    'curr_col = ActiveCell.Column '?
    
    'command_dos = Cells(ActiveCell.Row, ActiveCell.Column).Value '??
    
    command_dos = ActiveCell.Value
    '...
End Sub

    If TypeName(Sh) = "Worksheet" Then
        On Error Resume Next
        Set objLst = Target.ListObject
        If Not objLst Is Nothing Then
            CBstrDesc = "List Range Popup"
        Else
            CBstrDesc = "Cell"
        End If
        On Error GoTo 0
        '...
        Set prygun = Application.CommandBars(CBstrDesc) ... 'и так далее
        '...
    End If