Option Explicit
 
Sub PriceRandomQuarter()
    Dim rng As Range
    Set rng = Range("A10").CurrentRegion
     
    Call ClearTable(rng)
     
    With rng
        Dim x As Long, i As Long, cell As Range
        For x = 1 To .Rows.Count - 1
            Dim arrQuarter As Variant
            arrQuarter = GetRandQuarter()
         
            For i = LBound(arrQuarter) To UBound(arrQuarter)
                If arrQuarter(i) <> Empty Then
                    If i = 1 Then
                        Set cell = .Cells(x, 7)
                    ElseIf i = 2 Then
                        Set cell = .Cells(x, 11)
                    ElseIf i = 3 Then
                        Set cell = .Cells(x, 15)
                    ElseIf i = 4 Then
                        Set cell = .Cells(x, 19)
                    End If
                         
                    Dim price As Double
                    price = .Cells(x, 6)
                     
                    cell.Value = price
                    cell.Offset(, WorksheetFunction.RandBetween(1, 3)) = price
                End If
            Next i
        Next x
    End With
End Sub
 
Private Function GetRandQuarter() As Variant
    Dim arrQuarter(1 To 3) As Variant, rnd As Integer
    rnd = WorksheetFunction.RandBetween(LBound(arrQuarter), UBound(arrQuarter))
    arrQuarter(rnd) = 1
         
    GetRandQuarter = arrQuarter
End Function
 
Private Sub ClearTable(rng As Range)
    Dim table As Range
    Set table = rng.Offset(0, 6).Resize(rng.Rows.Count - 1, rng.Columns.Count - 6)
    table.ClearContents
End Sub

Dim arrQuarter(1 To 3) As Variant

Option Explicit

Sub PriceRandomQuarter()
    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    
    Call ClearTable(rng)
    
    With rng
        Dim x As Long, i As Long, cell As Range
        For x = 3 To .Rows.Count
            Dim arrQuarter As Variant, cntQuarter As Integer
            cntQuarter = 0
            arrQuarter = GetRandQuarter(cntQuarter)
        
            For i = LBound(arrQuarter) To UBound(arrQuarter)
                
                If i = 1 And arrQuarter(i) <> 0 Then
                    Set cell = .Cells(x, 9)
                ElseIf i = 2 And arrQuarter(i) <> 0 Then
                    Set cell = .Cells(x, 13)
                ElseIf i = 3 And arrQuarter(i) <> 0 Then
                    Set cell = .Cells(x, 17)
                ElseIf i = 4 And arrQuarter(i) <> 0 Then
                    Set cell = .Cells(x, 21)
                End If
                    
                If Not cell Is Nothing Then
                    Dim price As Double
                    price = .Cells(x, 5) / cntQuarter
                    
                    cell.Value = price
                    cell.Offset(, WorksheetFunction.RandBetween(1, 3) * -1) = price
                End If
                
                Set cell = Nothing
            Next i
        Next x
    End With
End Sub

Private Function GetRandQuarter(ByRef cntQuarter As Integer) As Variant
    Dim arrQuarter(1 To 4) As Variant, x As Long
    For x = LBound(arrQuarter) To UBound(arrQuarter)
        arrQuarter(x) = WorksheetFunction.RandBetween(0, 4)
        
        If arrQuarter(x) <> 0 Then cntQuarter = cntQuarter + 1
    Next x
    
    If cntQuarter = 0 Then Call GetRandQuarter(0)
    
    GetRandQuarter = arrQuarter
End Function

Private Sub ClearTable(rng As Range)
    Dim table As Range
    
    Set table = rng.Offset(2, 5)
    table.ClearContents
End Sub

Option Explicit

Sub GroupData()
    Dim arr As Variant
    arr = Range("A1").CurrentRegion.Value
    
    Dim x As Long, key As Variant, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim dictName As Object, dictYear As Object
    
    For x = LBound(arr, 1) + 1 To UBound(arr, 1)
        key = arr(x, 1)
        If Not dict.Exists(key) Then dict.Add key, CreateObject("Scripting.Dictionary")
        
        Set dictName = dict(key)
        
        key = arr(x, 2)
        If Not dictName.Exists(key) Then dictName.Add key, CreateObject("Scripting.Dictionary")
    
        Set dictYear = dictName(key)
        
        key = arr(x, 6)
        If Not dictYear.Exists(key) Then
            dictYear.Add key, New Collection
            
            Dim coll As Collection
            Set coll = dictYear(key)
                
            coll.Add arr(x, 3), "start"
            coll.Add arr(x, 4), "end"
            coll.Add arr(x, 5), "duration"
        Else
            Dim item As Double
            item = WorksheetFunction.Min(coll("start"), arr(x, 3))
            coll.Remove "start"
            coll.Add item, "start"
            
            item = WorksheetFunction.Max(coll("end"), arr(x, 4))
            coll.Remove "end"
            coll.Add item, "end"
            
            item = WorksheetFunction.Sum(coll("duration"), arr(x, 5))
            coll.Remove "duration"
            coll.Add item, "duration"
        End If
    Next x
    
    Dim cell As Range
    Set cell = Range("I1") 'ячека, куда выгружать данные
    
    cell.CurrentRegion.ClearContents
    cell.Resize(, UBound(arr, 2)) = Array(arr(1, 1), arr(1, 2), arr(1, 3), _
                                          arr(1, 4), arr(1, 5), arr(1, 6))
    Set cell = cell.Offset(1)
    
    For Each key In dict.Keys
        
        Dim keyName As Variant
        For Each keyName In dict(key)
            
            Dim keyYear As Variant
            For Each keyYear In dict(key)(keyName)
                cell.Value = key
                cell.Offset(, 1).Value = keyName
                cell.Offset(, 5).Value = keyYear
                
                Set coll = dict(key)(keyName)(keyYear)
                cell.Offset(, 2).Value = coll("start")
                cell.Offset(, 3).Value = coll("end")
                cell.Offset(, 4).Value = coll("duration")
                
                Set cell = cell.Offset(1)
            Next keyYear
        Next keyName
    Next key
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    
    Dim ColumnChange As Range
    Set ColumnChange = rng.Columns(1)
    
    If Intersect(Target, ColumnChange) Is Nothing Then Exit Sub
    
    Dim color1 As Variant, color2 As Variant, colorRow As Variant
    color1 = RGB(217, 225, 242)
    color2 = RGB(255, 255, 255)
    colorRow = color2
        
    With ColumnChange
        Dim x As Long, compareWord As String
        For x = 2 To .Rows.Count
            If .Cells(x).Value <> compareWord Then
                compareWord = .Cells(x).Value
                
                If colorRow = color1 Then
                    colorRow = color2
                ElseIf colorRow = color2 Then
                    colorRow = color1
                End If
            End If
            
            rng.Rows(x).Interior.Color = colorRow
        Next x
    End With
End Sub

=СУММПРОИЗВ(ЛЕВСИМВ(E1:E9;НАЙТИ(" ";E1:E9))*1)

Function UnMergeCells(cell As Range)
    If cell.MergeCells Then
        Dim rng As Range
        Set rng = cell.MergeArea
        
        rng.UnMerge
    End If
End Function

Option Explicit

Sub CompareText_Main()
    Dim rng1 As Range, rng2 As Range
    Set rng1 = ThisWorkbook.Worksheets("Лист1").Range("A1").CurrentRegion
    Set rng2 = ThisWorkbook.Worksheets("Лист2").Range("A1").CurrentRegion
    
    Call CompareRanges(rng1, rng2)
End Sub

Private Sub CompareRanges(rng1 As Range, rng2 As Range)
    Dim where As Range
    Set where = rng1.Columns(1)
    
    Dim x As Long
    For x = 2 To rng2.Rows.Count
        Dim find As Long: find = 0
        find = RealFind(rng2.Cells(x, 1).Value, where)
        
        If find > 0 Then rng2.Cells(x, 2) = rng1.Cells(find, 2)
    Next x
End Sub

Function RealFind(ByVal what As String, rng As Range) As Long
    what = CleanString(what)
    
    Dim arrWhat As Variant
    arrWhat = Split(what, " ")
    
    Dim x As Long, where As String, result As Long
    For x = 1 To rng.Rows.Count
        result = 0
        where = rng.Cells(x).Value
        
        Dim n As Long
        For n = LBound(arrWhat) To UBound(arrWhat)
            Dim inString As Long: inString = 0
            inString = InStr(1, LCase(where), LCase(arrWhat(n)), vbTextCompare)
            
            If inString > 0 Then
                result = result + 1
            Else
                GoTo nextX
            End If
            
            If result = UBound(arrWhat) + 1 Then
                RealFind = x
                Exit Function
            End If
        Next n

nextX:
    Next x
End Function

Private Function CleanString(what As String) As String
    Dim RE As Object
    Set RE = CreateObject("VBScript.RegExp")
    RE.Global = True
    RE.Pattern = "[^\dА-Яа-яA-Za-z]"
    
    CleanString = Application.Trim(RE.Replace(what, " "))
End Function

Sub Макрос1()
    Dim fr As Frame, rw As Long: rw = 0
    For Each fr In ThisDocument.Frames
        Dim st As String
        st = fr.Range.Text
        
        Dim rng As Range
        Set rng = ThisDocument.Characters.Last
        
        rng.Text = st & vbNewLine
    Next fr
End Sub

Sub CombainData()
    Dim rng As Range
    Set rng = Range("J1:Y1") 'Диапазон данных
    
    Dim x As Long
    For x = 1 To rng.Cells.Count
        If rng.Cells(x) <> Empty Then
            Dim data As Range
            Set data = rng.Cells(x).CurrentRegion
            Set data = data.Offset(1).Resize(data.Rows.Count - 1)
            
            Dim rw As Long
            rw = Range("G" & Rows.Count).End(xlUp).Row + 1
            
            data.Copy Range("G" & rw)
            
            x = x + 3
        End If
    Next x
End Sub

Option Explicit

Sub InsertColumns()
    Dim rng As Range
    Set rng = Range("G1:L1") 'Диапазон данных
     
    Dim rngPast As Range
    Set rngPast = Range("A7:A9") 'Диапазон вставки
     
    Dim x As Long, cell As Range
    Set cell = rng.Cells(1)
     
    For x = 1 To rng.Cells.Count / 2
        Dim rw As Long
        rw = Range(cell, cell.End(xlDown)).Rows.Count
        
        Set cell = cell.Offset(, 1)
        cell.EntireColumn.Insert
        Set cell = cell.Offset(, -1)
         
        With Range(cell.Address).Resize(rw)
            .Value = rngPast.Cells(x).Value
            .Interior.Color = rngPast.Cells(x).Interior.Color
        End With
         
        Set cell = cell.Offset(, 2)
    Next x
End Sub

Sub InsertColumns()
    Dim rng As Range
    Set rng = Range("G1:L1") 'Диапазон данных
    
    Dim rngPast As Range
    Set rngPast = Range("A7:A9") 'Диапазон вставки
    
    Dim rw As Long
    rw = rng.CurrentRegion.Rows.Count
    
    Dim x As Long, cell As Range
    Set cell = rng.Cells(1)
    
    For x = 1 To rng.Cells.Count / 2
        Set cell = cell.Offset(, 1)
        cell.EntireColumn.Insert
        Set cell = cell.Offset(, -1)
        
        With Range(cell.Address).Resize(rw)
            .Value = rngPast.Cells(x).Value
            .Interior.Color = rngPast.Cells(x).Interior.Color
        End With
        
        Set cell = cell.Offset(, 2)
    Next x
End Sub

RE.Pattern = "[^\dА-Яа-яA-Za-z,()=]"

Option Explicit

Sub CompareText_Main()
    Dim rng1 As range, rng2 As range
    Set rng1 = GetRange("Основной диапазон")
    Set rng2 = GetRange("Диапазон для сравнения")
    
    If rng1.Rows.Count <> rng2.Rows.Count Then
        MsgBox "Диапазоны должны быть равны", vbCritical, "***"
        Exit Sub
    End If
    
    rng1.Font.Color = vbBlack
    rng2.Font.Color = vbRed
    
    Call CompareRanges(rng1, rng2)
End Sub

Private Sub CompareRanges(rng1 As range, rng2 As range)
    Dim x As Long
    For x = 1 To rng1.Rows.Count
        
        Dim where As String, find As String
        where = rng2.Cells(x).Value
        find = RealFind(rng1.Cells(x).Value, where)
        
        If find <> Empty Then
            Dim arrSpl As Variant
            arrSpl = Split(find, ";")
            
            Dim i As Long
            For i = LBound(arrSpl) To UBound(arrSpl) - 1
                
                Dim word As String: word = arrSpl(i)
                Dim q As Integer, step As Integer
                step = IIf(Len(word) = 1, 1, Len(word))
                For q = 1 To Len(where) Step step
                    Dim inString As Long
                    inString = InStr(q, LCase(where), LCase(word), vbTextCompare)
                    
                    If inString > 0 Then
                        rng2.Cells(x).Characters(inString, step).Font.Color = vbBlack
                        q = inString + step
                    End If
                Next q
            Next i
        End If
    Next x
End Sub

Function RealFind(ByVal what As String, ByVal where As String) As String
    what = CleanString(what)
    
    Dim arrWhat As Variant
    arrWhat = Split(what, " ")

    Dim n As Long
    For n = LBound(arrWhat) To UBound(arrWhat)
        Dim inString As Long: inString = 0
        inString = InStr(1, LCase(where), LCase(arrWhat(n)), vbTextCompare)
        
        Dim result As String
        If inString > 0 Then result = result & arrWhat(n) & ";"
    Next n
    
    RealFind = result
End Function

Private Function CleanString(what As String) As String
    Dim RE As Object
    Set RE = CreateObject("VBScript.RegExp")
    RE.Global = True
    RE.Pattern = "[^\dА-Яа-яA-Za-z]"
    
    CleanString = Application.Trim(RE.Replace(what, " "))
End Function

Private Function GetRange(header As String) As range
    Set GetRange = Application.InputBox(header, "Выделите диапазон", , , , , , 8)
End Function

Option Explicit

Dim rw As Long

Sub DirectoryOfSubsurfaceUse()
    On Error Resume Next
    
    Cells.Clear
    rw = 2
    
    Dim page As Long
    For page = 1 To 40
        Dim URL As String
        URL = "https://uvspwa.sgp72.ru/api/search/companies?page=" & page
    
        Dim oHTTP As MSXML2.XMLHTTP
        Set oHTTP = GetHTTP(URL)
    
        Dim coll As Collection
        Set coll = JsonConverter.ParseJson(oHTTP.ResponseText)
        
        Dim item As Dictionary
        For Each item In coll
            Dim guid As String
            guid = item("guid")
            
            URL = "https://uvspwa.sgp72.ru/api/search/companies/" & guid
            Set oHTTP = GetHTTP(URL)
            
            Dim collCompany As Collection
            Set collCompany = JsonConverter.ParseJson("[" & oHTTP.ResponseText & "]")
            
            Dim dict As Scripting.Dictionary
            Set dict = collCompany.item(1)
            
            Call PrintValues(dict)
        Next item
    Next page
    
    Set oHTTP = Nothing
    Set coll = Nothing
    Set collCompany = Nothing
End Sub

Private Sub PrintValues(dict As Scripting.Dictionary)
    On Error Resume Next
    
    Dim cl As Long: cl = 1
    Dim key As Variant
    For Each key In dict.Keys
        If Not key Like "guid*" Then
        If TypeName(dict(key)) <> "Collection" Then
            Dim item As String
            item = dict(key)
            
            If Cells(1, cl) = Empty Then Cells(1, cl) = key
            If Err.Number = 0 Then Cells(rw, cl) = item
            Err.Clear
            
            cl = cl + 1
        Else
            If Cells(1, cl) = Empty Then Cells(1, cl) = key
            cl = cl + 1
            
            Dim collItem As Collection
            Set collItem = dict(key)
            
            Dim dictNext As Scripting.Dictionary
            For Each dictNext In collItem
                Dim keyNext As Variant
                For Each keyNext In dictNext.Keys
                    If Not keyNext Like "guid*" Then
                        item = dictNext(keyNext)
                        
                        If Cells(1, cl) = Empty Then Cells(1, cl) = keyNext
                        If Err.Number = 0 Then Cells(rw, cl) = item
                        Err.Clear
                
                        cl = cl + 1
                    End If
                Next keyNext
            Next dictNext
        End If
        End If
    Next key
    
    rw = rw + 1
End Sub

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

rng2.Font.Color = vbRed

rng2.Cells(x).Characters(inString, Len(word)).Font.Color = vbBlack

Option Explicit

Sub CompareText_Main()
    Dim rng1 As Range, rng2 As Range
    Set rng1 = GetRange("Основной диапазон")
    Set rng2 = GetRange("Диапазон для сравнения")
    
    If rng1.Rows.Count <> rng2.Rows.Count Then
        MsgBox "Диапазоны должны быть равны", vbCritical, "***"
        Exit Sub
    End If
    
    rng1.Font.Color = vbBlack
    rng2.Font.Color = vbBlack
    
    Call CompareRanges(rng1, rng2)
End Sub

Private Sub CompareRanges(rng1 As Range, rng2 As Range)
    Dim x As Long
    For x = 1 To rng1.Rows.Count
        
        Dim where As String, find As String
        where = rng2.Cells(x).Value
        find = RealFind(rng1.Cells(x).Value, where)
        
        If find <> Empty Then
            Dim arrSpl As Variant
            arrSpl = Split(find, ";")
            
            Dim i As Long
            For i = LBound(arrSpl) To UBound(arrSpl) - 1
                Dim inString As Long: inString = 0
                Dim word As String: word = arrSpl(i)
                inString = InStr(1, LCase(where), LCase(word), vbTextCompare)
                
                rng2.Cells(x).Characters(inString, Len(word)).Font.Color = vbRed
            Next i
        End If
    Next x
End Sub

Function RealFind(ByVal what As String, ByVal where As String) As String
    what = CleanUp(what)
    
    Dim arrWhat As Variant
    arrWhat = Split(what, " ")

    Dim n As Long
    For n = LBound(arrWhat) To UBound(arrWhat)
        Dim inString As Long
        inString = 0
        inString = InStr(1, LCase(where), LCase(arrWhat(n)), vbTextCompare)
        
        Dim result As String
        If inString > 0 Then result = result & arrWhat(n) & ";"
    Next n
    
    RealFind = result
End Function

Private Function CleanUp(what As String)
    Dim RE As Object
    Set RE = CreateObject("VBScript.RegExp")
    RE.Global = True
    RE.Pattern = "[^\dА-Яа-яA-Za-z]"
    CleanUp = Application.Trim(RE.Replace(what, " "))
End Function

Private Function GetRange(header As String) As Range
    Set GetRange = Application.InputBox(header, "Выделите диапазон", , , , , , 8)
End Function

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