Option Explicit

Sub погремушка_трещотка()
    Dim a, b, c, i&, j&, k&, m&, n&, o&
    
    With Sheets("многоблочная")
        With .ListObjects(1)
            a = .Range.Value
            ReDim c(1 To UBound(a, 1))
                For i = 1 To UBound(a, 1)
                    If Len(Trim$(a(i, 1))) = 0 Then
                        j = j + 1
                        c(j) = i
                    End If
                Next
                j = j + 1
                c(j) = i
            ReDim Preserve c(1 To j)
            ReDim b(1 To (UBound(a, 1) - j) * (UBound(a, 2) / 4), 1 To 4)
                For j = 2 To UBound(c)
                    For i = 1 To UBound(a, 2) Step 4
                        For m = 0 To 3
                            n = o
                            For k = c(j - 1) + 1 To c(j) - 1
                                n = n + 1
                                b(n, m + 1) = a(k, i + m)
                            Next
                        Next
                        o = n
                    Next
                Next
            .Unlist
        End With
        With .Range("A1")
            .Resize(UBound(a, 1), UBound(a, 2)).Clear
            .Resize(1, 4).Value = Array("Столбец1", "Столбец2", "Столбец3", "Столбец4")
            .Offset(1, 0).Resize(n, 4).Value = b
            .Parent.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = "Таблица1"
        End With
        '.Name = "одноблочная"
    End With
End Sub

Option Explicit

Private Sub UserForm_Initialize()
    ' при необходимости, какой-то код
End Sub

Private Sub CommandButton1_Click()
    Dim i&, c As Control, chbx, stlb$
    
    ReDim chbx(1 To Me.Controls.Count)
        For Each c In Me.Controls
            If TypeName(c) = "CheckBox" Then
                If c.Value = True Then
                    i = i + 1
                    chbx(i) = c.Caption
                    c.Value = False
                End If
            ElseIf TypeName(c) = "OptionButton" Then
                If c.Value = True Then
                    stlb = Split(Application.Trim(c.Caption), " ", 2, 0)(1)
                    c.Value = False
                End If
            End If
        Next
        If Len(stlb) = 0 Or i = 0 Then Exit Sub
    ReDim Preserve chbx(1 To i)
    
    With Sheets("Лист1")
        .Columns(stlb).Cells(1).Resize(i, 1).Value = Application.Transpose(chbx)
    End With
End Sub

Sub test2_2()
    Dim dic As Object, evc As New Collection, svc As New Collection
    Dim chto
    
    svc.Add 1.15
    chto = svc(svc.Count)
    Debug.Print "svc(" & svc.Count & ") = "; chto
    
    Set dic = CreateObject("Scripting.Dictionary")
        dic.Add "name", svc
        chto = dic("name")(svc.Count)
        Debug.Print "dic(" & dic.Count & ") = dic(""name"") = "; chto
        
    evc.Add dic.Item("name")
    chto = evc(evc.Count)(dic.Count)
    Debug.Print "evc(" & evc.Count & ") = "; chto
    
    evc.Add 116.16
    chto = evc(evc.Count)
    Debug.Print "evc(" & evc.Count & ") = "; chto
    
        If dic.Exists("name") Then dic.Item("name") = 1.22
        chto = dic("name")
        Debug.Print "dic(" & dic.Count & ") = dic(""name"") = "; chto
End Sub

test_dict.Item("name") = exist_vals_coll(1)

Option Explicit

Sub moto_tzykl()
    Dim c As Range, fa As String, fd As Range, rg As Range
    
    Set rg = Sheets("Лист1").Range("A2:A16").Cells
        For Each c In Sheets("Лист1").Range("G1:G5").Cells
                    'rg.Find(What,    After,                   LookIn,   LookAt, SearchOrder)
            Set fd = rg.Find(c.Value, rg.Cells(rg.Rows.Count), xlValues, xlPart, xlByRows)
            If Not fd Is Nothing Then
                fa = fd.Address
                Do
                    fd.Value = c.Value
                    Set fd = rg.FindNext(fd)
                Loop Until fd Is Nothing Or fd.Address = fa
                Set fd = Nothing
            End If
        Next
    Set rg = Nothing
End Sub

Option Explicit

Sub menu()
    Dim komnaty As UserForm1
    
    Set komnaty = New UserForm1
        Load komnaty
        komnaty.Show
    Set komnaty = Nothing
End Sub

Option Explicit

Private Sub UserForm_Initialize()
    Dim a, c As Control
    
    a = Array("Kirdyk", "Zakroy") 'isklyucheniya
    
    For Each c In Me.Controls
        If TypeOf c Is MSForms.CommandButton Then
            If IsError(Application.Match(c.Name, a, 0)) Then c.Tag = c.Name
        End If
    Next
End Sub

Private Sub nazva(nzv As String)
    Me.Nazvanye.Value = nzv
    Worksheets("Razmery").Range("A1").Value = nzv
    'Unload Me
End Sub

Private Sub Zal_Click()
    nazva Me.Zal.Tag
End Sub

Private Sub Kukhnya_Click()
    nazva Me.Kukhnya.Tag
End Sub

Private Sub Spalnya_Click()
    nazva Me.Spalnya.Tag
End Sub

Private Sub Zakroy_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub Kirdyk_Click()
    End
End Sub

Option Explicit

Sub k_odnomu()
    Dim a, b, c, i&, j&, r&
    
    Set a = Range("B2").CurrentRegion
        Set b = a.Columns(1): j = a.Columns.Count - 1
            Set c = a.Offset(0, 1).Resize(a.Rows.Count, j).Rows
                Range("G1").Value = Join(Application.Index(c(1).Value, 1, 0), vbNullString)
                For i = 2 To c.Count
                    r = Range("G" & Rows.Count).End(xlUp).Row + 1
                    Range("G" & r).Resize(j, 1).Value = b(1).Cells(i).Value
                    Range("H" & r).Resize(j, 1).Value = Application.Transpose(c(i).Value)
                Next
    c = Empty: b = Empty: a = Empty
End Sub

Option Explicit

Sub aaa_2()
    Dim dL1, dH1, dL2, dH2, i&, j&, k&, q, r
    
    r = Array("A1:A30", "B1:B30", "C3")
    
    For i = LBound(r) To UBound(r)
        q = Range(r(i)).Value
        
        If IsArray(q) Then
            Debug.Print "Arr r#" & i, "rng = " & r(i)
            dL1 = LBound(q, 1): Debug.Print "Low indx of 1st dim " & dL1
            dH1 = UBound(q, 1): Debug.Print "Upr indx of 1st dim " & dH1
            dL2 = LBound(q, 2): Debug.Print "Low indx of 2nd dim " & dL2
            dH2 = UBound(q, 2): Debug.Print "Upr indx of 2nd dim " & dH2
            
            For k = dL1 To dH2
                For j = dL1 To dH1
                    Debug.Print "Elmt #(" & j & "," & k & ") = " & q(j, k)
                Next
            Next
            Debug.Print "---------"
        End If
    Next
End Sub

Option Explicit

Sub aaa()
    Dim a, b, i&
    
    a = Array("1.1", "0.2", "0.3", "0.4", "0.9", "1.44", "5.25")
    ReDim b(UBound(a), 0)
    
    For i = 0 To UBound(a)
        b(i, 0) = "'" & a(i)
    Next
    
    Range("A1").Resize(i, 1).Value = b
End Sub

Option Explicit

Sub aaa()
    Dim a, b, c, i&, j&, k&
    
    a = Sheets("Исходные данные").Range("A1").CurrentRegion.Value
    ReDim b(1 To ((UBound(a, 2) - 2) * (UBound(a, 1) - 1)) + 1, 1 To 4)
    c = Array("Артикул", "Дата", "Ключевое слово", "Позиция")
    k = 1
    
    For i = 1 To 4
        b(k, i) = c(i - 1)
    Next
    For j = 3 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            k = k + 1
            b(k, 1) = a(i, 1)
            b(k, 2) = a(1, j)
            b(k, 3) = a(i, 2)
            b(k, 4) = a(i, j)
        Next
    Next
    
    With Sheets("Исходные данные")
        With .Range("A1")
            .CurrentRegion.ClearContents
            .Resize(UBound(b, 1), 4).Value = b
        End With
    End With
End Sub

Option Explicit

'Какой-то сетевой каталог для временных файлов
'Необходима консультация по теме с сетевым администратором
Const pthind As String = "Z:\TEMP\Indicators\ForXls\fleopn.txt"

Private Sub Workbook_Open()
    Dim n As Byte: n = FreeFile(0)
    Reset
    On Error Resume Next
    Open pthind For Output Access Write Lock Write As #n
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Reset
    On Error Resume Next
    Kill pthind
End Sub

Option Explicit

Const pthind As String = "Z:\TEMP\Indicators\ForXls\fleopn.txt"
Const pthwbk As String = "C:\path\workbook.xlsm"

Sub abc_xyz()
    Dim xlap As Object, xlwb As Object
    
    If Len(Dir(pthind, vbNormal)) > 0 Then
        On Error Resume Next
            Kill pthind
            If Err.Number <> 0 Then
                MsgBox "Запись запрещена, файл используется": Exit Sub
            End If
        On Error GoTo 0
    End If
    
    Set xlap = CreateObject("Excel.Application")
    xlap.Visible = True
    Set xlwb = xlap.Workbooks.Open(pthwbk)
    '... Какой-то код
    xlwb.Close True: Set xlwb = Nothing
    xlap.Quit: Set xlap = Nothing
End Sub

Option Explicit

Sub xyz_0()
    Dim a, crt As String, i As Long, p
    
    With ThisWorkbook.Sheets("List1")
        a = .Range("A1:E" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
        crt = Join(Application.Index(.Range("F3:H3").Value, 0), vbNullString)
        
        For i = 1 To UBound(a, 1)
            a(i, 5) = a(i, 1) & a(i, 2) & a(i, 3)
        Next
        
        p = Application.Match(crt, Application.Index(a, 0, 5), 0)
        If Not IsError(p) Then .Range("I3").Value = a(p, 4)
    End With
End Sub

Sub xyz_1()
    Dim a, crt As String, i As Long
    
    With ThisWorkbook.Sheets("List1")
        a = .Range("A1:D" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
        crt = Join(Application.Index(.Range("F3:H3").Value, 0), vbNullString)
        
        For i = 1 To UBound(a, 1)
            If a(i, 1) & a(i, 2) & a(i, 3) = crt _
            Then .Range("I3").Value = a(i, 4): Exit For
        Next
    End With
End Sub

Option Explicit

Sub abcdf()
    Dim i As Long, fnd As String, rplc As String, txtrng As Object
    
    Selection.HomeKey Unit:=wdStory
    
    Set txtrng = ActiveDocument.Range
    txtrng.Find.ClearFormatting
    txtrng.Find.Replacement.ClearFormatting
    
    Do While txtrng.Find.Execute(FindText:="ref\[*\]ref", MatchWildcards:=True)
        i = i + 1
        rplc = "[" & i & "]"
        fnd = ActiveDocument.Range(Start:=txtrng.Start, End:=txtrng.End).Text
        txtrng.Find.Execute FindText:=fnd, MatchWholeWord:=True, MatchWildcards:=False, _
                        Forward:=True, Wrap:=wdFindContinue, ReplaceWith:=rplc, _
                        Replace:=wdReplaceAll
    Loop
End Sub

Option Explicit

Private tbnme As String

Private Sub UserForm_Initialize()
    Dim i As Long
    
    For i = 1 To 10
        UserForm1.ListBox1.AddItem "Zapis' - " & i
    Next
End Sub

'Private Sub TextBox1_Enter()
'    tbnme = "TextBox1"
'End Sub

'Private Sub TextBox2_Enter()
'    tbnme = "TextBox2"
'End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    tbnme = "TextBox1"
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    tbnme = "TextBox2"
End Sub

Private Sub CommandButton1_Click()
    Dim txt As String
    
    If Len(tbnme) = 0 Then Exit Sub
    txt = Me.Controls(tbnme).Value
    
    MsgBox "Tekushchiy 'TextBox' eto: " & Chr(34) & tbnme & Chr(34) & vbNewLine & _
           "a tekst eto: '" & txt & "'"
End Sub

ДАТА(ЗНАЧЕН(ЛЕВСИМВ($B1;4));ПОИСКПОЗ(ПРАВСИМВ($B1;ДЛСТР($B1)-НАЙТИ(" ";СЖПРОБЕЛЫ($B1);6));{"январь";"февраль";"март";"апрель";"май";"июнь";"июль";"август";"сентябрь";"октябрь";"ноябрь";"декабрь"};0);1)

Sub aaa()
    Dim rg As Range, frd As Range
    
    Set rg = Range("A1").CurrentRegion
    rg.AutoFilter Field:=2, Criteria1:="<0"
    On Error Resume Next
        With rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
            Set frd = .SpecialCells(xlCellTypeVisible).Areas(1).Rows(1)
        End With
    On Error GoTo 0
    rg.AutoFilter
    If Not frd Is Nothing Then
        Range("D2:E2").Value = Array(Application.Min(frd), Application.Max(frd))
        Set frd = Nothing
    End If
    Set rg = Nothing
End Sub

Sub xyz()
    Dim i&, rg As Range
    
    With ActiveSheet
        Set rg = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
        
        For i = rg.Areas.Count To 1 Step -1
            'With rg.Areas(i).Range("A1")
            'With rg.Areas(i).Cells(1)
            With rg.Areas(i)
                .Select
                .Interior.ColorIndex = 9 - i
            End With
            Application.Wait (Now + TimeValue("00:00:02"))
        Next
        
        .Range("A1").CurrentRegion.Interior.ColorIndex = xlNone 'xlColorIndexNone
    End With
    
    Set rg = Nothing
End Sub

Function cipcip$(ByVal sval$, sdel$)
    Dim asdel&: asdel = AscW(sdel)
    Do While AscW(sval) = asdel
        sval = Right$(sval, Len(sval) - 1)
    Loop
    cipcip = sval
End Function

Sub picpic()
    Dim t!: t = Timer
    Const strd$ = "X"
    Dim a, i&
    
    With ActiveSheet
        a = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
        'Debug.Print Round(Timer - t, 3)
        For i = 1 To UBound(a, 1)
            a(i, 1) = cipcip(a(i, 1), strd)
        Next
        'Debug.Print Round(Timer - t, 3)
    With ActiveSheet
        .Range("B1:B" & i - 1).Value = a
    End With
    'Debug.Print Round(Timer - t, 3)
End Sub

Option Explicit

Sub IvanovIvanIvanovich()
    Const pth$ = "C:\Temp\Papka\"
    Const pttrn$ = "??.??.????_*.xlsx" ' 18.10.2022_IvanovIvanIvanovich.xlsx
    
    Dim d, cdte As Date, fle$, s, mdte&, mfle$
    
    cdte = Date
    mdte = 10000000
    fle = Dir(pth & pttrn, vbNormal)
    
    Do Until Len(fle) = 0
        s = Split(Split(fle, "_", 2, 0)(0), ".", 3)
        d = cdte - DateSerial(s(2), s(1), s(0))
        If Not IsError(d) Then
            If d < mdte Then mdte = d: mfle = fle
        End If
        fle = Dir()
    Loop
    
    If TypeName(ActiveSheet) = "Worksheet" Then
        ActiveSheet.Range("A2:B2").Value = Array(mdte, mfle)
    End If
End Sub