Option Explicit

Private dict As Object

Sub CheckAdvancePayments()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Диапазон Сведений об авансе
    Dim rangeAdvancePayments As Range
    Set rangeAdvancePayments = ws.Range("A2:C38")
    
    'Диапазон Сведений о поставках
    Dim rangeDelivery As Range
    Set rangeDelivery = ws.Range("E2:F62")
    
    'Ячейка, с которой начинается выгрузка отчета
    Dim cellResult As Range
    Set cellResult = ws.Range("H2")
    
    
    With rangeAdvancePayments
        Dim x As Long
        For x = 1 To .Rows.Count
            Dim datePayment As Date, dateDelivery As Date, SumPayment As Double
            datePayment = .Cells(x, 1)
            dateDelivery = .Cells(x, 2)
            SumPayment = .Cells(x, 3)
            
            Dim SumDelivery As Double
            SumDelivery = GetSumDelivery(rangeDelivery, datePayment, _
                                dateDelivery, SumPayment, cellResult)
            
            cellResult.Value = SumPayment - SumDelivery
            
            cellResult.Offset(, 2).ClearContents
            If SumPayment - SumDelivery > 0 Then
                cellResult.Offset(, 2).Value = "Остался аванс, который не закрывается поставками"
            End If
            
            Set cellResult = cellResult.Offset(1)
        Next x
    End With
    
    
    Set dict = Nothing
End Sub

Private Function GetSumDelivery(rangeDelivery As Range, _
                                datePayment As Date, dateDelivery As Date, _
                                SumPayment As Double, cellResult As Range) As Double
    Dim cell As Range
    Set cell = cellResult.Offset(, 1)
    cell.ClearContents
    
    With rangeDelivery
        Dim x As Long, Sum As Double
        For x = 1 To .Rows.Count
            If Not dict.Exists(x) Then
                If CDate(.Cells(x, 1)) >= datePayment Then
                If CDate(.Cells(x, 1)) <= dateDelivery Then
                    Sum = Sum + CDbl(.Cells(x, 2))
                    dict(x) = Empty
                    
                    cell = cell & Format(CDate(.Cells(x, 1)), "dd.mm.yyyy") & _
                            " - " & Format(CDbl(.Cells(x, 2)), "#0.00") & vbNewLine
                    
                    If SumPayment <= Sum Then
                        GoTo ExitFunc
                    End If
                End If
                End If
            End If
        Next x
    End With

ExitFunc:
    If Len(cell.Value) > 0 Then cell.Value = Left(cell.Value, Len(cell.Value) - 1)
    GetSumDelivery = Sum
End Function

Option Explicit

Private dict As Object

Sub CheckAdvancePayments()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Диапазон Сведений об авансе
    Dim rangeAdvancePayments As Range
    Set rangeAdvancePayments = ws.Range("A2:C38")
    
    'Диапазон Сведений об поставках
    Dim rangeDelivery As Range
    Set rangeDelivery = ws.Range("E2:F62")
    
    'Ячейка, с которой начинается выгрузка отчета
    Dim cellResult As Range
    Set cellResult = ws.Range("H2")
    
    
    
    
    With rangeAdvancePayments
        Dim x As Long
        For x = 1 To .Rows.Count
            Dim datePayment As Date, dateDelivery As Date, SumPayment As Double
            datePayment = .Cells(x, 1)
            dateDelivery = .Cells(x, 2)
            SumPayment = .Cells(x, 3)
            
            Dim SumDelivery As Double
            SumDelivery = GetSumDelivery(rangeDelivery, datePayment, dateDelivery, SumPayment)
            
            cellResult.Value = SumPayment - SumDelivery
            If SumPayment - SumDelivery > 0 Then
                cellResult.Offset(, 1) = "Остался аванс, который не закрывается поставками"
            End If
            
            Set cellResult = cellResult.Offset(1)
        Next x
    End With
    
    Set dict = Nothing
End Sub

Private Function GetSumDelivery(rangeDelivery As Range, _
                                datePayment As Date, dateDelivery As Date, _
                                SumPayment As Double) As Double
    With rangeDelivery
        Dim x As Long, Sum As Double
        For x = 1 To .Rows.Count
            If Not dict.Exists(x) Then
                If CDate(.Cells(x, 1)) >= datePayment Then
                If CDate(.Cells(x, 1)) <= dateDelivery Then
                    Sum = Sum + CDbl(.Cells(x, 2))
                    dict(x) = Empty
                    
                    If SumPayment <= Sum Then
                        GetSumDelivery = Sum
                        Exit Function
                    End If
                End If
                End If
            End If
        Next x
    End With
    
    GetSumDelivery = Sum
End Function

cell.Offset(, WorksheetFunction.RandBetween(1, 3)) = price

Set table = Range("G10:V563") 'Удаляем данные по кварталам и месяцам

Set rng = Range("A10:V564") 'Таблица с данными

=ЕСЛИ(E3="";"";МАКС($A$2:A2)+1)

Option Explicit
  
Sub PriceRandomQuarter()
    Dim rng As Range
    Set rng = Range("A10:V564") 'Таблица с данными
      
    Call ClearTable
      
    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) '7 - столбец 1 квартала
                    ElseIf i = 2 Then
                        Set cell = .Cells(x, 11) '11 - столбец 2 квартала
                    ElseIf i = 3 Then
                        Set cell = .Cells(x, 15) '15 - столбец 3 квартала
                    ElseIf i = 4 Then
                        Set cell = .Cells(x, 19) '19 - столбец 4 квартала
                    End If
                          
                    Dim price As Double
                    price = .Cells(x, 6) '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()
    Dim table As Range
    Set table = Range("G10:V563") 'Удаляем данные по кварталам и месяцам
    table.ClearContents
End Sub

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