Option Explicit

Sub курочка_ряба()
    Dim ws As Object
    On Error Resume Next
    For Each ws In Worksheets
        With ws
            If .Name <> "Заказ" Then
            'If .Visible Then
                With .Range("A6:F42")
                    .AutoFilter Field:=6, Criteria1:="0"
                    With .Offset(1, 0).Resize(.Rows.Count - 1)
                        .SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
                    End With
                    If Err.Number <> 0 Then Err.Clear
                    .AutoFilter
                End With
            End If
        End With
    Next
End Sub

Option Explicit

Sub V_LOOK_UP()
    Const rngadrs = "$A$1:$B$34"
    Const shnme = "Source"
    
    Dim adrs As String, frmla As String
    
    adrs = Application.InputBox("Select a Cell", Type:=8).Address(0, 0)
    frmla = "=VLOOKUP(" & "$" & adrs & "," & shnme & "!" & rngadrs & ",2,0)"
    
    Range(adrs).Offset(0, 1).Formula = frmla
End Sub

Option Explicit

Sub UserForm_Initialize()
    Dim strval As Variant
    
    strval = "1|2|3|4|5|6"
    
    strval = "{" & Replace(strval, "|", ",", 1, -1, 1) & "}"
    strval = Evaluate(strval)
    
    Me.ComboBox4.List() = strval
End Sub

Option Explicit

Sub razbivka_po_strokam()
    Const dlm = ","
    
    Dim i&, ii&, j&, jj&, k&, n&
    Dim arr, splt, tbl
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With Range("A1").CurrentRegion
        arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    End With
    
    ii = UBound(arr, 1): jj = UBound(arr, 2)
    For i = 1 To ii
        j = j + UBound(Split(arr(i, 7), dlm, -1, 0)) + 1
    Next
    ReDim tbl(1 To j, 1 To jj)
    jj = jj - 1
    
    For i = 1 To ii
        splt = Split(arr(i, 7), dlm, -1, 0)
        For n = 0 To UBound(splt)
            k = k + 1
            For j = 1 To jj
                tbl(k, j) = arr(i, j)
            Next
            tbl(k, j) = splt(n)
        Next
    Next
    
    arr = Empty: splt = Empty
    Range("A2").Resize(k, jj + 1).Value = tbl
    tbl = Empty
    
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

t_o = Array("AA1", "AA2", "AA3", "AA4", "AA5", "AA6", "AA7", "AA8", "AA9", "AA10")

'или

t_o = Array("B1", "E2", "J3", "D4", "A5", "Z6", "X7", "U8", "F9", "I10")

'и так далее

Option Explicit

Sub a_b_frml()
    
    Const xlALst = "List1" 'Otkuda
    Const xlBLst = "List1" 'Gde
    Const prcsn = "3"      'Tochnost' rezul'tata v formule
    
    Dim f_rm: f_rm = Application.GetOpenFilename("Fayle xls (*.xls*),*.xls*", , "Otkuda")
            If f_rm = False Then Exit Sub
    Dim t_o: t_o = Application.GetOpenFilename("Fayle xls (*.xls*),*.xls*", , "Gde")
            If t_o = False Then Exit Sub
    
    Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
            Dim wkA As Workbook: Set wkA = Workbooks.Open(f_rm, 0, True) 'Otkuda
            Dim wkB As Workbook: Set wkB = Workbooks.Open(t_o, 0, False) 'Gde
        Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    
    f_rm = Array("A1", "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9", "A10")        'yacheyki - otkuda
    t_o = Array("A1", "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9", "A10")         'yacheyki - gde
    Dim d: d = Array("1.1", "0.9", "2.4", "3.9", "4.2", "5", "6.7", "7.8", "8", "9") 'deliteli chisel
    
    Dim ix As Long: ix = LBound(f_rm)
    Dim iy As Long: iy = UBound(f_rm)
    Dim i As Long, tbl: ReDim tbl(ix To iy)
    
    For i = ix To iy
        tbl(i) = wkA.Sheets(xlALst).Range(f_rm(i)).Value
        If Not IsNumeric(tbl(i)) Then tbl(i) = Val(Replace(tbl(i), ",", ".", 1, -1, 0))
    Next
    
    wkA.Close False: Set wkA = Nothing
    
    Application.ScreenUpdating = False
        For i = ix To iy
            wkB.Sheets(xlBLst).Range(t_o(i)).Formula = "=ROUND(" & tbl(i) & "/" & d(i) & "," & prcsn & ")"
        Next
    Application.ScreenUpdating = True
    
    Set wkB = Nothing
    
End Sub

Sub abc_xyz()
    Range("E6:E300").Value = Range("E6:E300").Value
End Sub

Dim arrlnks, i As Long, wB As Workbook
Set wB = ActiveWorkbook
arrlnks = wB.LinkSources(Type:=xlLinkTypeExcelLinks)

If Not IsEmpty(arrlnks) Then
    For i = 1 To UBound(arrlnks)
        wB.BreakLink Name:=arrlnks(i), Type:=xlLinkTypeExcelLinks
    Next
End If

ActiveSheet.Hyperlinks.Delete
Cells.Validation.Delete
Cells.FormatConditions.Delete

Sheets("!ККК").Cells(i, 14).Value = Sheets("12").Cells(2348, 12).Value
Sheets("!ККК").Cells(i, 27).Value = Sheets("12").Cells(2346, 14).Value
Sheets("!ККК").Cells(i, 28).Value = Sheets("12").Cells(2341, 11).Value
Sheets("!ККК").Cells(i, 29).Value = Sheets("12").Cells(2343, 12).Value
Sheets("!ККК").Cells(i, 30).Value = Sheets("12").Cells(2344, 12).Value
Sheets("!ККК").Cells(i, 31).Value = Sheets("12").Cells(2345, 12).Value
Sheets("!ККК").Cells(i, 32).Value = Sheets("12").Cells(2346, 12).Value
Sheets("!ККК").Cells(i, 33).Value = Sheets("12").Cells(2347, 12).Value
Sheets("!ККК").Cells(i, 34).Value = Sheets("12").Cells(2348, 12).Value

Set shККК = Sheets("!ККК")
Set sh12 = Sheets("12")

k = 0
rc = Array(2348, 12, 2346, 14, 2341, 11, 2343, 12, 2344, 12, 2345, 12, 2346, 12, 2347, 12, 2348, 12)

shККК.Cells(i, 14).Value = sh12.Cells(rc(0), rc(1)).Value

For j = 27 To 34
    k = k + 2
    shККК.Cells(i, j).Value = sh12.Cells(rc(k), rc(k + 1)).Value
Next

    On Error Resume Next
        
        With ActiveSheet.Range("H2")
            .AutoFilter Field:=2, Criteria1:="=1", Operator:=xlOr, Criteria2:="=2"
        End With
        
    On Error GoTo 0

Option Explicit

Sub splitti_fitti()
    
    Dim StartTime As Single
    StartTime = Timer
    
    Dim Itm As Long, vCol As Long ', MyCount As Long
    Dim savepath As String ', path_f As String
    Dim ws As Worksheet
    Dim MyArr
    
    vCol = 1
    With ThisWorkbook
        'path_f = .Path
        savepath = .Path & "\To Send"
        Set ws = .Sheets("main")
    End With
    'savepath = path_f & "\To Send"
    
    If Dir(savepath, vbDirectory) = "" Then MkDir savepath
    
    With Application
        .ScreenUpdating = False: .EnableEvents = False
        .Calculation = xlManual: .DisplayAlerts = False
    End With
    ActiveWindow.View = xlNormalView
    
    With ws
        .Range("A1:A" & .Cells(.Rows.Count, vCol).End(xlUp).Row).AdvancedFilter _
                    Action:=xlFilterCopy, CopyToRange:=.Range("EE1"), Unique:=True
        .Range("EE1").CurrentRegion.Sort Key1:=.Range("EE2"), Order1:=xlAscending, Header:=xlYes
        MyArr = Application.Transpose(.Range("EE2:EE" & .Cells(.Rows.Count, "EE").End(xlUp).Row).Value)
        .Range("EE1").CurrentRegion.Clear
        '.Range("A1").CurrentRegion.AutoFilter
    End With
    
    For Itm = 1 To UBound(MyArr)
        Workbooks.Add
        
        With ws.Range("A1").CurrentRegion
            .AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
            .SpecialCells(xlVisible).Copy
        End With
        
        With ActiveWorkbook
            With ActiveSheet
                With .Range("A1")
                    .PasteSpecial xlPasteAll
                    Application.CutCopyMode = False
                    .Select
                End With
                .Rows("1:4").Insert Shift:=xlShiftDown
                With .Range("C1")
                    .Value = "Additional field:"
                    .Interior.ColorIndex = 6
                End With
                .Columns("A:G").AutoFit
                'MyCount = MyCount + .Range("A" & .Rows.Count).End(xlUp).Row - 5 '?
            End With
            .SaveAs savepath & ("\" & MyArr(Itm) & ".xlsb"), 50
            .Close False
        End With
    Next
    
    ws.AutoFilterMode = False
    Set ws = Nothing
    
    With Application
        .DisplayAlerts = True: .Calculation = xlAutomatic
        .EnableEvents = True: .ScreenUpdating = True
    End With
    
    Debug.Print Round(Timer - StartTime, 3) & " Secs for processing"
    
End Sub

Header1|Header2|Header3|Header4|Header5
abcdefg|2019/1/12|458.89|-2.98|00000
bcadgfe;2021/1/15|-555.555;666.666|00001
lmkruzx|2021/1/9;777.777;444.444|00002

Sub fikoo_mikoo()
    Const strPth = "C:\Temp\"
    Const fle = "MSLOleg_csv.csv"
    
    Workbooks.OpenText Filename:=strPth & fle, Origin:=65001, StartRow:=1, DataType:=xlDelimited, _
                       TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Semicolon:=True, _
                       Other:=True, OtherChar:="|", _
                       FieldInfo:=Array(Array(1, 2), Array(2, 5), Array(3, 1), Array(4, 1), Array(5, 1)), _
                       DecimalSeparator:=".", TrailingMinusNumbers:=True
    ActiveSheet.Range("A1").CurrentRegion.EntireColumn.AutoFit
End Sub

HT = InputBox("Input temperature:")

= Selection.Cells(i, 3) & "." & Selection.Cells(i, 2) & "." & Selection.Cells(i, 1)

DateSerial(Cells(i, "A").Value, Cells(i, "B").Value, Cells(i, "C").Value)

.NumberFormat = "dd/mm/yyyy"

Sub xyz()
    
    On Error Resume Next
        With Sheets("List1")
            .Shapes(Application.Trim(.Range("B1").Value)).Copy
        End With
        
        If Err.Number <> 0 Then MsgBox "Tut nichego net - konets": Exit Sub
    On Error GoTo 0
    
    With Sheets("List2")
        .Paste Destination:=.Range("A1")
    End With
    
    Application.CutCopyMode = False
    
End Sub

Sub aaa()
    If Not verifyuser(Environ("UserName")) Then MsgBox "Stoy, predyavi propusk !": End
    MsgBox "Aaa, Vkhodite pozhaluysta ! Proshu Vas, zakhodite !"
End Sub

Function verifyuser(strStr As String) As Boolean
    verifyuser = False
    If IsError(Application.Match(strStr, Sheets("md").Columns("H"), 0)) Then Exit Function
    verifyuser = True
End Function

'ili

Sub bbb()
    If IsError(Application.Match(Environ("UserName"), Sheets("md").Columns("H"), 0)) Then _
    MsgBox "Stoy, predyavi propusk !": End
    MsgBox "Aaa, Vkhodite pozhaluysta ! Proshu Vas, zakhodite !"
End Sub

Option Explicit

Private skipthis As Boolean

Private Sub UserForm_Initialize()
    Const tblnme = "tab_A"
    Const col = "A"
    
    Dim r As Long, arr As Variant
    
    skipthis = True ' Chtoby opustit 'cmbBox_Change' (i drugiye) vo vremya initsializatsii 'UserForm1'
    
    With Sheet2.ListObjects.Item(tblnme).DataBodyRange.Columns(col)
        ReDim arr(1 To .Rows.Count, 1 To 2)
        For r = .Cells(1, 1).Row - 1 To .Rows.Count
            arr(r, 1) = .Cells(r, 1).Value
            '(0, 0)=>"=Sheet2!A2"/ (1, 0)=>"=Sheet2!A$2"/ (0, 1)=>"=Sheet2!$A2"/ ()=>"=Sheet2!$A$2"
            arr(r, 2) = "='" & .Parent.Name & "'!" & .Cells(r, 1).Address(1, 0)
        Next
    End With
    
    With UserForm1
        .Caption = "Okno"
        With .cmbBox
            .BoundColumn = 1 ' '.Value' in ComboBox
            '.TextColumn = 2 ' '.Text' in ComboBox => no ne tut !
            .ColumnCount = 1 ' Tolko pervaya kolonka
            .List() = arr: arr = Empty
            .ListIndex = -1
        End With
    End With
    
    skipthis = False
End Sub

Private Sub cmbBox_Change()
    If skipthis = True Then Exit Sub
    '...
End Sub

Private Sub btnSave_Click()
    With Sheet1
        With .Range("A1,A10,A22")
            'Application.EnableEvents = False ' ???
                .Formula = Me.cmbBox.Column(1, Me.cmbBox.ListIndex)
                '.Offset(0, 1).Value = Me.cmbBox.Value ' Tolko dlya testov => zakommentirovat
            'Application.EnableEvents = True ' ???
        End With
    End With
End Sub

xOutMsg = "<html><body><p style=""font-family:'Arial';font-size:22pt;""><b>" & _
          Sheets("Main").Range("D2").Text & "</b><br>" & _
          Sheets("Main").Range("D3").Text & "</p></body></html>"

Option Explicit

Sub meowky_meowky_meow()
    Const srcSht = "List1", srcRngBeg = "A1", srcCol1 = 3, srcCol2 = 1
    Const trgSht = "List2", trgRngBeg = "A1"
    Const fltr = "All XLS Files (*.xls*),*.xls*,XLS Files (*.xls),*.xls,XLSX Files (*.xlsx),*.xlsx"
    Const fltrind = 1
    '-----------------------------------------------------------------------------------
    Dim srcvar: srcvar = Application.GetOpenFilename(fltr, fltrind, "Select SOURCE file", , False)
    Application.Wait (Now + TimeValue("00:00:01"))
    Dim trgvar: trgvar = Application.GetOpenFilename(fltr, fltrind, "Select TARGET file", , False)
    If srcvar = False Or trgvar = False Then Exit Sub
    '-----------------------------------------------------------------------------------
    Dim srcWkb: srcWkb = Right(Trim(srcvar), Len(Trim(srcvar)) - InStrRev(Trim(srcvar), Application.PathSeparator, -1, 1))
    Dim trgWkb: trgWkb = Right(Trim(trgvar), Len(Trim(trgvar)) - InStrRev(Trim(trgvar), Application.PathSeparator, -1, 1))
    If srcWkb = trgWkb Then Exit Sub
    If srcWkb = ThisWorkbook.Name Or trgWkb = ThisWorkbook.Name Then Exit Sub
    srcWkb = Empty: trgWkb = Empty
    '-----------------------------------------------------------------------------------
    Set srcWkb = Workbooks.Open(Filename:=srcvar, UpdateLinks:=0, ReadOnly:=True)
    Set trgWkb = Workbooks.Open(Filename:=trgvar, UpdateLinks:=0, ReadOnly:=False)
    srcvar = Empty: trgvar = Empty
    '-----------------------------------------------------------------------------------
    With srcWkb
        With .Sheets(srcSht)
            With .Range(srcRngBeg).CurrentRegion
                srcvar = .Offset(1, srcCol1 - 1).Resize(.Columns(srcCol1).Rows.Count - 1, 1).Value
                trgvar = .Offset(1, srcCol2 - 1).Resize(.Columns(srcCol2).Rows.Count - 1, 1).Value
            End With
        End With
        .Close False
    End With
    Set srcWkb = Nothing: srcWkb = Empty
    '-----------------------------------------------------------------------------------
    With trgWkb
        With .Sheets(trgSht)
            .Select
            With .Range(trgRngBeg)
                With .Cells(.CurrentRegion.Rows.Count, 1)
                    .Select
                    .Offset(1, 0).Resize(UBound(srcvar, 1), 1).Value = srcvar
                    .Offset(1, 1).Resize(UBound(trgvar, 1), 1).Value = trgvar
                End With
            End With
        End With
    End With
    srcvar = Empty: trgvar = Empty
    Set trgWkb = Nothing: trgWkb = Empty
    '-----------------------------------------------------------------------------------
    With ThisWorkbook
        .Saved = True
        .Close False
    End With
End Sub