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

'Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        If Trim(UserForm1.TextBox1.Value) = "" Then
            MsgBox ("введите артикул")
        Else
            'ActiveCell.FormulaR1C1 = "=VLOOKUP(UserForm1.TextBox1.Value,'Паллеты к отгрузке'!C[-10]:C[-8],3,0)"
            ActiveCell.FormulaR1C1 = "=VLOOKUP(" & Chr(34) & Trim(UserForm1.TextBox1.Value) & Chr(34) & ",'Паллеты к отгрузке'!C[-10]:C[-8],3,0)"
        End If
    End If
End Sub

Option Explicit

Sub poisk()
Dim fnd As Range, cl%, rw&, r&: r = 16
Const adrRngTBL1$ = "B2:E12"

    Do Until Cells(r, "B").Value = ""
        Set fnd = Range(adrRngTBL1).Find(Cells(r, "B").Value, Range("B2"), xlValues, xlWhole, xlByRows)
        If Not fnd Is Nothing Then
            rw = fnd.Row: cl = fnd.Column: Set fnd = Nothing
            With Cells(r, "B")
                .Offset(0, 1).Value = Cells(rw, "G").Value
                .Offset(0, 2).Value = Cells(1, cl).Value
                .Offset(0, 3).Value = Cells(rw, cl + 7).Value
            End With
        End If
        r = r + 1
    Loop
End Sub

Sub Makros()
    Columns("B:B").Cut
    Columns("O:O").Insert Shift:=xlToRight
    Columns("O:O").Cut
    Columns("B:B").Insert Shift:=xlToRight
End Sub

Option Explicit

Sub naydi_chego_net()
Dim vim%, i%, chsl_nenayd%, strk&: strk = 1
Dim itogo&: itogo = 0                           'itogo ne naydennykh
Dim tkct$, tbl
Dim nayd As Range

    Application.ScreenUpdating = False
    Do Until Trim(Range("A" & strk).Value) = ""
        chsl_nenayd = 0                         'chislo ne naydennykh
        tkct = ""
        tbl = Split(Trim(Range("A" & strk).Value), ",", -1, 1)
        vim = UBound(tbl)
        For i = 0 To vim
            Set nayd = Range("b" & strk & ":p" & strk).Find(Trim(tbl(i)), Range("b" & strk), xlValues, xlWhole, xlByColumns)
            If nayd Is Nothing Then
                chsl_nenayd = chsl_nenayd + 1   'chislo ne naydennykh
                tkct = tkct & "," & Trim(tbl(i))
                If Left(tkct, 1) = "," Then tkct = Right(tkct, Len(tkct) - 1)
                Range("q" & strk).Value = tkct
            End If
            Set nayd = Nothing
        Next
        Range("r" & strk).Value = chsl_nenayd   'chislo ne naydennykh
        itogo = itogo + chsl_nenayd             'itogo ne naydennykh
        strk = strk + 1
    Loop
    Range("r" & strk).FormulaR1C1 = "=sum(r[" & 1 - strk & "]c:r[-1]c)" 'itogo ne naydennykh - variant I
    Range("r" & strk).Offset(0, 1).Value = itogo                        'itogo ne naydennykh - variant II
    Application.ScreenUpdating = True
End Sub