Sub SaveWebPageToEdisclosureFolder()
    Dim URL As String
    Dim FileName As String
    Dim DateStamp As String
    Dim FolderPath As String
    Dim FilePath As String
    Dim http As Object
    Dim stream As Object
    Dim FSO As Object
    Dim oFolder As Object

    ' Адрес сайта
    URL = "https://www.e-disclosure.ru/portal/files.aspx?id=1976&type=3"

    ' Формируем отметку времени
    DateStamp = Format(Now, "yyyy-mm-dd_HH-MM-SS")

    ' Путь к папке "E-disclosure" на рабочем столе
    FolderPath = Environ("USERPROFILE") & "\Desktop\E-disclosure\"
    FolderPath = ThisWorkbook.Path
    
    ' Проверка и создание папки, если её нет
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(FolderPath) Then
        Set oFolder = FSO.CreateFolder(FolderPath)
    Else
        Set oFolder = FSO.GetFolder(FolderPath)
    End If

    ' Полное имя файла
    FileName = "site_" & DateStamp & ".html"
    FilePath = oFolder.Path & Application.PathSeparator & FileName

    ' Загружаем страницу
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", URL, False
    http.Send

    ' Проверка статуса и сохранение
    If http.Status = 200 Then
        Dim txtFile As Scripting.TextStream
        Set txtFile = FSO.OpenTextFile(FilePath, 2, True)
        txtFile.Write http.responsetext
        txtFile.Close
        
        MsgBox "Файл успешно сохранён:" & vbCrLf & FilePath, vbInformation
    Else
        MsgBox "Ошибка загрузки страницы. Код: " & http.Status, vbExclamation
    End If
End Sub

Option Explicit

Sub DownLoadPicture()
    Dim URL As String
    URL = "https://www.nordsonmedical.com/Shop/Fluid-Management/Luer-Fitting/?start=0&itemsPer=100000"
    
    Dim oHTTP As New MSXML2.XMLHTTP
    Set oHTTP = GetHTTPDoc(URL)
    
    Dim oHTML As New MSHTML.HTMLDocument
    oHTML.body.innerHTML = oHTTP.responseText
    
    Dim dict As Scripting.Dictionary
    Set dict = GetLink(oHTML)
    
    Call DownLoad(dict)
    
    Set oHTTP = Nothing
    Set oHTML = Nothing
    Set dict = Nothing
End Sub

Private Sub DownLoad(dict As Scripting.Dictionary)
    On Error Resume Next
    
    Dim key As Variant, cnt As Long: cnt = 0
    For Each key In dict.Keys
        Dim NameFile As String, FilePath As String
        NameFile = Split(key, "/")(UBound(Split(key, "/")))
        FilePath = ThisWorkbook.Path & Application.PathSeparator & NameFile
        
        Dim oHTTP As MSXML2.XMLHTTP
        Set oHTTP = GetHTTPDoc(CStr(key))
        
        Dim AStream As New ADODB.Stream
        With AStream
            .Type = 1
            .Open
            .Write oHTTP.responseBody
            .SaveToFile FilePath, 1
            .Close
        End With
        
        Set oHTTP = Nothing
        Set AStream = Nothing
    Next key
End Sub

Private Function GetLink(oHTML As MSHTML.HTMLDocument) As Scripting.Dictionary
    Dim HTMLColl As MSHTML.IHTMLElementCollection
    Set HTMLColl = oHTML.getElementsByClassName("product-front")
    
    Dim dict As New Scripting.Dictionary
    
    Dim HTMLItem As MSHTML.IHTMLElement
    For Each HTMLItem In HTMLColl
        Dim elem As MSHTML.IHTMLElement
        Set elem = HTMLItem.ChildNodes.item(1).ChildNodes.item(0).ChildNodes.item(1).ChildNodes.item(2)
        
        Dim link As String
        link = "https://www.nordsonmedical.com" & elem.getAttribute("data-src")
        
        dict(link) = Empty
    Next HTMLItem
    
    Set GetLink = dict
    Set dict = Nothing
End Function

Private Function GetHTTPDoc(URL As String) As MSXML2.XMLHTTP
    Dim oHTTP As New MSXML2.XMLHTTP
    With oHTTP
        .Open "GET", URL, False
        .Send
    End With
    
    Set GetHTTPDoc = oHTTP
    Set oHTTP = Nothing
End Function

Function Ocurrence(v_Source As String, v_Pattern As String) As String
    Dim v_RegExp As Object
    Set v_RegExp = CreateObject("vbscript.regexp")
    With v_RegExp
        .Pattern = v_Pattern
        .Global = True
      
        Dim MC As Object
        Set MC = .Execute(v_Source)
    End With
    
    Dim item As Object, txt As String
    For Each item In MC
        txt = txt & item.Value & ", "
    Next item
    
    Ocurrence = txt
End Function

Sub www()
    Dim rng As Range
    Set rng = Range("A3", Range("A3").End(xlDown))
    rng.EntireRow.Hidden = True
    
    Dim DateStart As Date, DateStop As Date
    DateStart = DateSerial(2024, 12, 31)
    DateStop = DateSerial(Year(DateStart) + 1, Month(DateStart), Day(DateStart))
    
    Dim cell As Range
    For Each cell In rng.Cells
        If CDate(cell.Value) >= DateStart And CDate(cell.Value) <= DateStop Then
            cell.EntireRow.Hidden = False
        End If
    Next cell
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim cell As Range
    For Each cell In Range("P2", Range("P2").End(xlDown)).Cells
        dict(cell.Value) = cell.Address
    Next cell
    
    Dim key As Variant
    For Each key In dict.Keys
        If Target.Value Like "*" & key & "*" Then
            Range(dict(key)).Interior.Color = vbYellow
            Exit Sub
        End If
    Next key
    
    Set dict = Nothing
End Sub

Sub Wildberries()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set makros = ActiveWorkbook

    'раскомментировать
    'Sheets("Содержание").Cells(4, 3) = Sheets("-").Cells(5, 1) & " в разрезе на социально-демографические показатели"

    Workbooks.Open ThisWorkbook.Path & "\*_et_report_*.xlsx"
    Set Tabs = ActiveWorkbook
    
    Sheets("Contents").Delete
    For i = 1 To Sheets.Count
        If i > Sheets.Count Then Exit For
        If Sheets(i).Name Like "Sig*" Then
            Sheets(i).Delete
            i = i - 1
        End If
    Next
    
    'Визуал для соц-дема с фильтрами
    Sheets("Tables").Activate
    ActiveWindow.ScrollRow = 1
    ActiveSheet.Shapes(1).Delete
    Cells.Font.Name = "Arial"
    Cells.Font.Size = 10
    Cells.Font.Color = vbBlack
    Cells.Interior.Color = vbWhite
    Cells.Borders().Color = vbWhite
    Cells.HorizontalAlignment = xlCenter
    Cells.VerticalAlignment = xlCenter
    
    Rows("1:3").Delete
    Rows(1).Font.Color = vbWhite
    Rows(1).Interior.Color = RGB(179, 17, 160)
    Rows(1).Borders().LineStyle = xlNone
    Cells(1, 2) = makros.Sheets("-").Cells(5, 1) & " " & makros.Sheets("-").Cells(6, 1)
    SplitWidth = Cells(10, Columns.Count).End(xlToLeft).Column
    Range(Cells(7, 3), Cells(8, SplitWidth)).Copy Cells(3, 3)
'    Range(Cells(3, 3), Cells(4, 4)).Merge
    Rows(6).Insert
    Range(Cells(5, 3), Cells(5, SplitWidth)).Merge
    Cells(5, 3) = makros.Sheets("-").Cells(5, 1) & " " & makros.Sheets("-").Cells(6, 1)
    Range(Cells(3, 3), Cells(5, SplitWidth)).Interior.Color = RGB(179, 17, 160)
    Range(Cells(3, 3), Cells(5, SplitWidth)).Font.Color = vbWhite
    Range(Cells(3, 3), Cells(5, SplitWidth)).Font.Bold = True
    Rows(7).Insert
    Rows(Cells.Find("Base", , , xlWhole).Row).Copy Cells(7, 1)
    Rows(7).Font.Italic = True
    Cells(7, 2) = "Все респонденты"
    Rows(8).Insert
    Columns(2).Font.Bold = False
    Rows(1).Font.Bold = True
    Columns(2).HorizontalAlignment = xlLeft
    Columns(3).Insert
    Columns(3).ColumnWidth = 5.5
    SplitWidth = SplitWidth + 1
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lRow
        If Cells(i, 1).Font.Underline = 2 And Cells(i, 1) <> "contents" Then
            Base = i
            Do While Cells(Base + 1, 2) <> "w. Base"
                Base = Base + 1
            Loop
            Rows(i + 1 & ":" & i + 4).Delete
            Rows(i).HorizontalAlignment = xlLeft
            Rows(i).UnMerge
            Cells(i, 2) = Cells(i, 1)
            Cells(i, 2).Font.Bold = True
            Range(Cells(i, 2), Cells(i, SplitWidth)).Merge
            Range(Cells(i + 1, 2), Cells(Base - 3, SplitWidth)).Borders().Color = RGB(191, 191, 191)
            Range(Cells(i, 2), Cells(i, SplitWidth)).Borders(xlEdgeTop).Color = vbBlack
            Range(Cells(i, 2), Cells(i, SplitWidth)).Borders(xlEdgeBottom).Color = vbBlack
            Range(Cells(i, 2), Cells(i, SplitWidth)).Borders(xlEdgeTop).Weight = -4138
            Range(Cells(i, 2), Cells(i, SplitWidth)).Borders(xlEdgeBottom).Weight = -4138
            'сформировать подписи для Cells(i, 2) и Cells(Base - 1, 2) на основе Cells(i, 2)
            Cells(Base - 1, 2) = Cells(i, 2)
            Cells(Base - 1, 2).Hyperlinks.Delete
            Cells(Base - 1, 2).Font.Name = "Arial"
            Cells(Base - 1, 2).Font.Size = 10
            Cells(Base - 1, 2).Font.Italic = True
            Cells(Base - 1, 2).Font.Color = RGB(174, 170, 170)
            Range(Cells(i + 1, 3), Cells(Base - 4, 3)) = "%"

            If Not Range(Cells(i + 1, 2), Cells(Base - 4, 2)).Find("MEAN", , , xlWhole) Is Nothing Then
                MEANrow = Range(Cells(i + 1, 2), Cells(Base - 4, 2)).Find("MEAN", , , xlWhole).Row
                Rows(MEANrow).Font.Underline = False
                Rows(MEANrow).Font.Bold = False
                Cells(MEANrow, 3) = "mean"
                Rows(MEANrow + 1).Hidden = True
            End If
            
            AnsFrow = i + 1
            Do While Cells(AnsFrow + 1, 3) = "%"
                AnsFrow = AnsFrow + 1
            Loop
            For Each c In Range(Cells(i + 1, 4), Cells(AnsFrow, SplitWidth))
                c.Value = c.Value * 100
                c.NumberFormat = "0.0"
            Next
            Rows(Base - 3).Hidden = True
            Rows(Base - 2).Delete
        End If
    Next
    
    Columns(3).HorizontalAlignment = xlCenter
    Columns(3).Font.Color = RGB(191, 191, 191)
    Columns(1).Delete
    Columns(1).ColumnWidth = 54.56
    
    Cells(8, 3).Select
    ActiveWindow.FreezePanes = True
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    makros.Sheets("-").Activate
    Range(Cells(8, 1), Cells(13, 2)).Copy Tabs.Sheets(1).Cells(lRow + 2, 1)
    Tabs.Sheets(1).Activate
    'Визуал для соц-дема с фильтрами
    
    Sheets(1).Copy after:=Sheets(1)
    Sheets(1).Activate
    
    SplitWidth = Cells(7, Columns.Count).End(xlToLeft).Column
'    i = 9
'    Do While Cells(i + 1, 1).Interior.Color <> 16777215
'        i = i + 1
'    Loop
'    SplitHeight = i - 9
    Dim SplitSC(99) 'первые столбцы сплитов
    Dim SplitFC(99) 'последние столбцы сплитов
    Dim SplitAns(99) 'количество ответов в сплите
    SplitSC(1) = 3
    SplitsCount = 1
    
    Sheets().Add after:=Sheets(2)
    Sheets(3).Name = "Списки"
'    Sheets().Add after:=Sheets(3)
'    Sheets(4).Name = "FormatConditions"
    Sheets(1).Activate
    ListCol = 1
'    FirstW = Cells(9 + SplitHeight, 3)
    For i = 3 To SplitWidth
        If Cells(3, i) <> Cells(3, i + 1) Then
            Set ListSheet = Sheets("Списки").Columns(ListCol)
            SplitFC(SplitsCount) = i
            Range(Cells(4, SplitSC(SplitsCount)), Cells(4, SplitFC(SplitsCount))).Copy
            Sheets("Списки").Cells(1, ListCol).PasteSpecial Transpose:=True
            ListSheet.UnMerge
            ListSheet.RemoveDuplicates Columns:=1
            ListFR = 1
            Do While Sheets("Списки").Cells(ListFR, ListCol) <> Empty
                Sheets("Списки").Cells(ListFR, ListCol + 1) = ListFR - 1
                ListFR = ListFR + 1
            Loop
            SplitAns(SplitsCount) = ListFR - 1
            ListCol = ListCol + 3
        
            SplitsCount = SplitsCount + 1
            SplitSC(SplitsCount) = i + 1
        End If
'        If Cells(9 + SplitHeight, i + 1) = FirstW And waves = Empty Then waves = i - 2
    Next
    SplitsCount = SplitsCount - 1
        
    For i = SplitsCount To 1 Step -1
        For i1 = SplitSC(i) + 2 To SplitFC(i)
            Columns(SplitSC(i) + 2).Delete
        Next
    Next
    SplitWidth = Cells(7, Columns.Count).End(xlToLeft).Column
    
'    Range(Cells(10, 3), Cells(7 + SplitHeight, SplitWidth)).Copy Cells(10 - SplitHeight, 3)
'    Range(Cells(10 - SplitHeight, 3), Cells(7, 2 + SplitsCount * 2)).HorizontalAlignment = xlCenter
    For i = 2 To SplitsCount
'        If Cells(11 - SplitHeight, 3 + 2 * (i - 1)) = "-" Then GoTo NextI
        ColLet = Mid(Cells(1, (i - 1) * 3 + 1).Address(True, False), 1, InStr(Cells(1, (i - 1) * 3 + 1).Address(True, False), "$") - 1)
        Cells(4, 3 + 2 * (i - 1)).Validation.Add Type:=xlValidateList, _
        Formula1:="='Списки'!$" & ColLet & "$1:$" & ColLet & "$" & SplitAns(i)
'NextI:
    Next
    
    Range(Cells(3, SplitsCount * 2 + 4), Cells(5, SplitsCount * 4 + 3)).Merge
    Range(Cells(3, SplitsCount * 2 + 4), Cells(5, SplitsCount * 4 + 3)).HorizontalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 2 + 4), Cells(5, SplitsCount * 4 + 3)).VerticalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 2 + 4), Cells(5, SplitsCount * 4 + 3)) = "Z/STDDEV"
    Range(Cells(3, SplitsCount * 2 + 4), Cells(5, SplitsCount * 4 + 3)).Font.Size = 15

    Range(Cells(3, SplitsCount * 4 + 6), Cells(5, SplitsCount * 6 + 5)).Merge
    Range(Cells(3, SplitsCount * 4 + 6), Cells(5, SplitsCount * 6 + 5)).HorizontalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 4 + 6), Cells(5, SplitsCount * 6 + 5)).VerticalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 4 + 6), Cells(5, SplitsCount * 6 + 5)) = "df"
    Range(Cells(3, SplitsCount * 4 + 6), Cells(5, SplitsCount * 6 + 5)).Font.Size = 15
    
    Range(Cells(3, SplitsCount * 6 + 8), Cells(5, SplitsCount * 8 + 7)).Merge
    Range(Cells(3, SplitsCount * 6 + 8), Cells(5, SplitsCount * 8 + 7)).HorizontalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 6 + 8), Cells(5, SplitsCount * 8 + 7)).VerticalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 6 + 8), Cells(5, SplitsCount * 8 + 7)) = "Base"
    Range(Cells(3, SplitsCount * 6 + 8), Cells(5, SplitsCount * 8 + 7)).Font.Size = 15
    
    Range(Cells(3, SplitsCount * 8 + 10), Cells(5, SplitsCount * 10 + 9)).Merge
    Range(Cells(3, SplitsCount * 8 + 10), Cells(5, SplitsCount * 10 + 9)).HorizontalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 8 + 10), Cells(5, SplitsCount * 10 + 9)).VerticalAlignment = xlCenter
    Range(Cells(3, SplitsCount * 8 + 10), Cells(5, SplitsCount * 10 + 9)) = "Total df"
    Range(Cells(3, SplitsCount * 8 + 10), Cells(5, SplitsCount * 10 + 9)).Font.Size = 15
    
        
    For i2 = 1 To SplitsCount
        ColLet1 = Mid(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 1).Address(True, False), 1, InStr(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 1).Address(True, False), "$") - 1)
        ColLet2 = Mid(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 2).Address(True, False), 1, InStr(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 2).Address(True, False), "$") - 1)
        ColLet = Mid(Cells(1, 3 + (i2 - 1) * 2).Address(True, False), 1, InStr(Cells(1, 3 + (i2 - 1) * 2).Address(True, False), "$") - 1)
    
        If i2 > 1 Then
            OffsetSpl = OffsetSpl + (SplitAns(i2 - 1) - 1) * 2
        Else
            OffsetSpl = 0
        End If
    
        Range(Cells(7, 3 + (i2 - 1) * 2), Cells(7, 2 + i2 * 2)).Formula = _
        "=INDIRECT(""'Соц-дем (2)'!RC["" & " & OffsetSpl & "+(VLOOKUP($" & ColLet & "$4,'Списки'!$" & ColLet1 & "$1:$" & ColLet2 & "$" & SplitAns(i2) & ",2,0))*" & 2 & " & ""]"",false)"
    Next
        
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    ff = ""
    For i = 7 To lRow
        If Cells(i, 1).Font.Bold = True Then
            Base = i
            Do While Cells(Base, 1) <> "w. Base"
                Base = Base + 1
            Loop
        
            f1 = Cells(i + 1, 3).Address(False, False)
            f2r = i + 1
            Do While Cells(f2r + 1, 2) = "%"
                f2r = f2r + 1
            Loop
            f2 = Cells(f2r, SplitWidth).Address(False, False)
            ff = ff & "," & f1 & ":" & f2
            
            For ff0 = f2r To Base
                If Cells(ff0, 2) = "mean" Then
                    ff = ff & "," & Cells(ff0, 3).Address(False, False) & ":" & Cells(ff0, SplitWidth).Address(False, False)
                End If
            Next
        
            For i2 = 1 To SplitsCount
                ColLet1 = Mid(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 1).Address(True, False), 1, InStr(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 1).Address(True, False), "$") - 1)
                ColLet2 = Mid(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 2).Address(True, False), 1, InStr(Sheets("Списки").Cells(1, (i2 - 1) * 3 + 2).Address(True, False), "$") - 1)
                ColLet = Mid(Cells(1, 3 + (i2 - 1) * 2).Address(True, False), 1, InStr(Cells(1, 3 + (i2 - 1) * 2).Address(True, False), "$") - 1)

                If i2 > 1 Then
                    OffsetSpl = OffsetSpl + (SplitAns(i2 - 1) - 1) * 2
                Else
                    OffsetSpl = 0
                End If
                
                Range(Cells(i + 1, 3 + (i2 - 1) * 2), Cells(Base, 2 + i2 * 2)).Formula = _
                "=INDIRECT(""'Tables (2)'!RC["" & " & OffsetSpl & "+(VLOOKUP($" & ColLet & "$4,'Списки'!$" & ColLet1 & "$1:$" & ColLet2 & "$" & SplitAns(i2) & ",2,0))*" & 2 & " & ""]"",false)"
            Next
            
            For wv = 0 To SplitsCount * 2 - 1
                For rr = i + 1 To Base - 1
                    If Cells(rr, 1) <> "MEAN" And Cells(rr, 1) <> "STDDEV" Then
                        std = Cells(rr, 3 + wv).Address(False, False)
                        Cells(rr, SplitWidth + 2 + wv).Formula = "=IF(" & std & "/100 * (1 -" & std & "/100)=0,1E-30," & std & "/100 * (1 -" & std & "/100))"
                    ElseIf Cells(rr, 1) = "MEAN" Then
                        std = Cells(rr + 1, 3 + wv).Address(False, False)
                        Cells(rr, SplitWidth + 2 + wv).Formula = "=IF(OR(" & std & "/100=0," & std & "="".""),1E-43," & std & "/100)"
                    End If
                Next
            Next
            
            nt = Cells(Base, 4).Address(False, False)
            For wv = 1 To SplitsCount * 2
                n1 = Cells(Base, 1 + wv).Address(False, False)  't
                n2 = Cells(Base, 2 + wv).Address(False, False)  'ch
                bs = Cells(Base, 2 + wv).Address(False, False)
                
                For rr = i + 1 To Base - 1
                    pt = Cells(rr, 4).Address(False, False)
                    p1 = Cells(rr, 1 + wv).Address(False, False)
                    p2 = Cells(rr, 2 + wv).Address(False, False)
                    stdt = Cells(rr, 13).Address(False, False)
                    std1 = Cells(rr, SplitsCount * 2 + 2 + wv).Address(False, False)
                    std2 = Cells(rr, SplitsCount * 2 + 3 + wv).Address(False, False)
                    
                    If Cells(rr, 2) <> "MEAN" And Cells(rr, 2) <> "STDDEV" Then
                        Cells(rr, SplitsCount * 4 + 5 + wv).Formula = _
                        "=(" & p2 & "-" & p1 & ")/100 / Sqrt(" & std1 & " / " & n1 & "+" & std2 & " / " & n2 & ")"
                    ElseIf Cells(rr, 2) = "MEAN" Then
                        Cells(rr, SplitsCount * 4 + 5 + wv).Formula2 = _
                        "=(" & p2 & "-" & p1 & ")/100 / Sqrt(POWER(" & std1 & ",2) / " & n1 & "+POWER(" & std2 & ",2) / " & n2 & ")"
                    End If
                
                    Cells(rr, SplitsCount * 6 + 7 + wv).Formula = "=" & bs
                    
                    If Cells(rr, 2) <> "MEAN" And Cells(rr, 2) <> "STDDEV" Then
                        Cells(rr, SplitsCount * 8 + 9 + wv).Formula = _
                        "=(" & p2 & "-" & pt & ")/100 / Sqrt(" & stdt & " / " & nt & "+" & std2 & " / " & n2 & ")"
                    ElseIf Cells(rr, 2) = "MEAN" Then
                        Cells(rr, SplitsCount * 8 + 9 + wv).Formula2 = _
                        "=(" & p2 & "-" & pt & ")/100 / Sqrt(POWER(" & stdt & ",2) / " & nt & "+POWER(" & std2 & ",2) / " & n2 & ")"
                    End If
                Next
            Next
           
            For ii = 1 To SplitsCount
                Range(Cells(i + 1, (SplitsCount * 2 + 2) * 2 + 2 + (ii - 1) * 2), Cells(Base - 1, (SplitsCount * 2 + 2) * 2 + 2 + (ii - 1) * 2)).ClearContents
                Range(Cells(i + 1, (SplitsCount * 2 + 2) * 3 + 2 + (ii - 1) * 2), Cells(Base - 1, (SplitsCount * 2 + 2) * 3 + 2 + (ii - 1) * 2)).ClearContents
                Range(Cells(i + 1, (SplitsCount * 2 + 2) * 4 + 2 + (ii - 1) * 2), Cells(Base - 1, (SplitsCount * 2 + 2) * 4 + 2 + (ii - 1) * 2)).ClearContents
            Next
            Range(Cells(i + 1, (SplitsCount * 2 + 2) * 4 + 3), Cells(Base - 1, (SplitsCount * 2 + 2) * 4 + 3)).ClearContents
        End If
    Next

    ff = Mid(ff, 2)
'    Range(ff).FormatConditions.Add(xlExpression, Formula1:="=AF10<30").Font.Color = RGB(191, 191, 191)
    With Range(ff).FormatConditions.Add(xlExpression, Formula1:="=V10>1,96")
        .Font.Color = RGB(0, 176, 80)
        .Font.Bold = True
        .StopIfTrue = False
    End With
    With Range(ff).FormatConditions.Add(xlExpression, Formula1:="=V10<-1,96")
        .Font.Color = vbRed
        .Font.Bold = True
        .StopIfTrue = False
    End With
    With Range(ff).FormatConditions.Add(xlExpression, Formula1:="=AP10>1,96")
        .Interior.Color = RGB(216, 228, 188)
        .StopIfTrue = False
    End With
    With Range(ff).FormatConditions.Add(xlExpression, Formula1:="=AP10<-1,96")
        .Interior.Color = RGB(230, 184, 183)
        .StopIfTrue = False
    End With
    
    For ii = 1 To SplitsCount
        Columns(3 + (ii - 1) * 2).Hidden = True
    Next
    
    Range(Cells(1, SplitsCount * 2 + 4), Cells(1, SplitsCount * 10 + 9)).EntireColumn.Hidden = True
    
    Sheets("Tables (2)").Visible = xlVeryHidden
    Sheets("Списки").Visible = xlVeryHidden
    
    
    
    
    
    
    
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Mid(Tabs.Name, 1, InStr(Tabs.Name, "_et_") - 1) & "_KSS.xlsx", FileFormat:=xlOpenXMLWorkbook
    Application.Quit

End Sub

Sub CellError()
    Dim rng As Range: Set rng = Selection
    Dim cell As Range, val As Variant: val = 0
    For Each cell In rng.Cells
        If cell <> Empty Then
            If cell.Value < val Then
                MsgBox "Ошибка в ячейке " & cell.Address, vbCritical, "***"
                cell.Select
            Else
                val = cell.Value
            End If
        End If
    Next cell
End Sub

Sub НовыйЛист()
    Call CreateData(CDate(Range("A1")))
End Sub

Private Sub CreateData(setDate As Date)
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        dict(ws.Name) = Empty
    Next ws
    
    Dim monthName As String
    monthName = Format(setDate, "MMMM")
    If monthName = "Декабрь" Then Exit Sub
    
    If CreateSheetMonth(dict, monthName) = False Then
        setDate = DateSerial(Year(setDate), Month(setDate) + 1, Day(setDate))
        Call CreateData(setDate)
    End If
    
    Set dict = Nothing
End Sub

Private Function CreateSheetMonth(dict As Object, _
                                  monthName As String) As Boolean
    If Not dict.Exists(monthName) Then
        Dim ws As Worksheet
        Set ws = Worksheets("Лист1")
        
        ws.Copy , ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ActiveSheet.Name = monthName
    Else
        CreateSheetMonth = True
    End If
End Function

Option Explicit

Sub TextToColumnFromCSV()
    Dim filePath As Variant
    filePath = GetPathCSV
    
    Dim arr As Variant
    arr = GetArray(filePath)
    
    Call PrintResult(arr)
End Sub

Private Sub PrintResult(arr As Variant)
    Dim startCell As Range
    Set startCell = [H3] 'стартовая ячейка для печати
    
    startCell.CurrentRegion.ClearContents
    
    Dim x As Long, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    For x = LBound(arr) To UBound(arr) - 1
        Dim arrSplit As Variant
        arrSplit = Split(arr(x), ";")
        
        Dim key As String
        key = arrSplit(0)
            
        If Not dict.Exists(key) Then
            dict(key) = Empty
            
            Dim cell As Range, n As Long: n = 1
            Set cell = startCell.Offset(0, dict.Count - 1)
            cell.Value = key
            cell.Offset(n) = arrSplit(1)
        Else
            n = n + 1
            cell.Offset(n) = arrSplit(1)
        End If

    Next x
    
    Set dict = Nothing
End Sub

Private Function GetArray(filePath As Variant) As Variant
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim oFile As Object
    Set oFile = FSO.OpenTextFile(filePath)
    
    Dim arr As Variant
    arr = oFile.ReadAll
    
    oFile.Close
    
    arr = Split(arr, vbCrLf)
    
    GetArray = arr
    
    Set FSO = Nothing
    Set oFile = Nothing
End Function

Private Function GetPathCSV() As Variant
    Dim filePath As Variant
    filePath = Application.GetOpenFilename("CSV files(*.csv),*.csv", 1, "Выбрать файл CSV", , False)
    
    If VarType(filePath) = vbBoolean Then Exit Function
    
    GetPathCSV = filePath
End Function

Sub ErrorRow()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Импорт")
    
    Dim table As ListObject
    Set table = ws.ListObjects(1)
    
    Dim cell As Range
    For Each cell In table.DataBodyRange.Cells
        If IsError(cell) Then
            MsgBox "Ошибка с строке N" & cell.Row, vbCritical + vbOKOnly, "Найдена ошибка"
        End If
    Next cell
End Sub

path = ThisWorkbook.path

Sub Main()
    Dim dictTxt As Scripting.Dictionary
    Set dictTxt = GetFiles(".txt")
    
    Dim dictIni As Scripting.Dictionary
    Set dictIni = GetFiles(".ini")
    
    Call CompareDict(dictTxt, dictIni)
End Sub

'Открываем файл для чтения
Private Sub ReadFile(path As String)
    Dim FSO As New Scripting.FileSystemObject
    Dim oFile As Scripting.TextStream
    Set oFile = FSO.OpenTextFile(path, ForReading, False)
    
    'Получаем массив данных
    Dim arr As Variant
    arr = oFile.ReadAll
    oFile.Close
    
    '=========================================================
    'тут Ваша обработка массива для получения нужных данных
    '=========================================================
    
    
    
    Set FSO = Nothing
    Set oFile = Nothing
End Sub

'Ищем два файла TXT и INI
Private Sub CompareDict(dictTxt As Scripting.Dictionary, _
                        dictIni As Scripting.Dictionary)
    Dim keyTxt As Variant, keyIni As Variant
    For Each keyTxt In dictTxt.Keys
        For Each keyIni In dictIni.Keys
            If keyIni Like "*" & keyTxt Then
                Call ReadFile(dictTxt(keyTxt))
                Call ReadFile(dictIni(keyIni))
            End If
        Next keyIni
    Next keyTxt
End Sub

'Собираем файлы TXT и INI в отдельные библиотеки
Private Function GetFiles(filter As String) As Scripting.Dictionary
    
    Dim path As String
    path = ThisWorkbook.path
    
    Dim FSO As New Scripting.FileSystemObject
    Dim oFolder As Scripting.Folder
    Set oFolder = FSO.GetFolder(path)
    
    Dim oFile As Scripting.File
    Dim dict As New Scripting.Dictionary
    For Each oFile In oFolder.Files
        If oFile.name Like "*" & filter Then
            Dim name As String
            name = oFile.name
            name = Split(name, filter)(0)
            
            dict(name) = oFile.path
        End If
    Next oFile
    
    Set GetFiles = dict
    Set FSO = Nothing
    Set oFolder = Nothing
    Set oFile = Nothing
    Set dict = Nothing
End Function

Function RE_Execute_First_Match(ИсходныйТекст As String, Шаблон As String, _
                                   Optional УчётРегистра As Boolean = False) As String
    Dim RE  As Object
    Dim MC As Object
    
    Set RE = CreateObject("VBScript.RegExp")
    
    With RE
         .IgnoreCase = Not (УчётРегистра)
         .Pattern = Шаблон
    End With
    
    Set MC = RE.Execute(ИсходныйТекст)
    
    If MC.Count Then RE_Execute_First_Match = MC(0) Else RE_Execute_First_Match = "нет соответствия"

End Function

=RE_Execute_First_Match(A21;"[А-Яа-я]+ [А-Я]{1}\.[А-Я]{1}\.")

let
    tiker = Excel.CurrentWorkbook(){[Name="INN"]}[Content][Column1]{0},
    url = "https://iss.moex.com/iss/securities.xml?q=" & tiker & "&iss.only=markets",
    tbl = Xml.Tables(Web.Contents(url))[Table]{0}[rows]{0}[row]{0}
in
    tbl

let
    from = Excel.CurrentWorkbook(){[Name="tableNew"]}[Content],
    names = Table.ColumnNames(from),
    lst = List.Transform(names, each {_, type number}),
    skip = List.Skip(lst),
    min = Table.AddColumn(from, "Min", each List.Min(skip), type number)

in
    min