Option Base 1
Function VenteSur_Func(XArr5, StN, QT, NextDeliv, EndRow)
    Dim XRow As Long
    Dim XArr6() As Variant
    Dim XArr7() As Variant
    Dim XArr8() As Variant
    ChDir "Путь к файлу"
    Workbooks.Open Filename:="Путь к файлу\VenteSurDern4Semaines" & StN & ".xls"
    Workbooks("VenteSurDern4Semaines" & StN & ".xls").Activate
    Worksheets("VenteSurDern4Semaines" & StN).Copy Before:=Workbooks("VenteSur012.xlsm").Sheets(1)
    Workbooks("VenteSurDern4Semaines" & StN & ".xls").Close SaveChanges:=False
    Workbooks("VenteSur012.xlsm").Activate
    Worksheets("VenteSurDern4Semaines" & StN).Select
    
    XRow = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    ReDim XArr6(1 To XRow - 1, 1 To 7) As Variant
    XArr6 = Worksheets("VenteSurDern4Semaines" & StN).Range("F2:L" & XRow).Value
    Worksheets("VenteSurDern4Semaines" & StN).Select
    ActiveWindow.SelectedSheets.Delete
    Worksheets("VenteSurDern4Semaines").Select
    ReDim XArr7(1 To XRow - 1, 1 To 5) As Variant
' сортировка данных по возрастанию
    xmin = XArr6(1, 1)
    For j = 1 To XRow - 1
        If xmin >= XArr6(j, 1) Then
            xmin = XArr6(j, 1)
            xmin1 = XArr6(j, 3)
            xmin2 = XArr6(j, 5)
            xmin3 = XArr6(j, 6)
            xmin4 = XArr6(j, 7)
        End If
    Next
    XArr7(1, 1) = xmin
    XArr7(1, 2) = xmin1
    XArr7(1, 3) = xmin2
    XArr7(1, 4) = xmin3
    XArr7(1, 5) = xmin4
    xmax = XArr6(1, 1)
    For j = 1 To XRow - 1
        If xmax <= XArr6(j, 1) Then
            xmax = XArr6(j, 1)
            xmax1 = XArr6(j, 3)
            xmax2 = XArr6(j, 5)
            xmax3 = XArr6(j, 6)
            xmax4 = XArr6(j, 7)
        End If
    Next
    XArr7(XRow - 1, 1) = xmax
    XArr7(XRow - 1, 2) = xmax1
    XArr7(XRow - 1, 3) = xmax2
    XArr7(XRow - 1, 4) = xmax3
    XArr7(XRow - 1, 5) = xmax4
    For i = XRow - 2 To 2 Step -1
        w = xmax
        k = XRow - i
        For j = 1 To XRow - 1
            If w > xmin And w <= xmax And w > XArr6(j, 1) And XArr6(j, 1) > XArr7(k - 1, 1) And XArr6(j, 1) <> xmin Then
                w = XArr6(j, 1)
                w1 = XArr6(j, 3)
                w2 = XArr6(j, 5)
                w3 = XArr6(j, 6)
                w4 = XArr6(j, 7)
            End If
        Next
        XArr7(k, 1) = w
        XArr7(k, 2) = w1
        XArr7(k, 3) = w2
        XArr7(k, 4) = w3
        XArr7(k, 5) = w4
    Next
    ReDim XArr8(1 To EndRow, 1 To 4) As Variant
    For i = 1 To EndRow
        For j = 1 To XRow - 1
            If XArr7(j, 1) = XArr5(i, 1) Then
                XArr8(i, 1) = XArr7(j, 2)
                XArr8(i, 2) = XArr7(j, 3)
                Data1 = XArr7(j, 4)
                Data2 = XArr7(j, 5)
                If Data1 = 0 Then
                    XArr8(i, 3) = Data1
                Else
                    XArr8(i, 3) = Right(Data1, 2) & "." & Mid(Data1, 3, 2) & "." & Left(Data1, 2)
                End If
                If Data2 = 0 Then
                    XArr8(i, 4) = Data2
                Else
                    XArr8(i, 4) = Right(Data2, 2) & "." & Mid(Data2, 3, 2) & "." & Left(Data2, 2)
                End If
                Exit For
            End If
            If XArr7(j, 1) > XArr5(i, 1) Then
                XArr8(i, 1) = 0
                XArr8(i, 2) = 0
                XArr8(i, 3) = 0
                XArr8(i, 4) = 0
                Exit For
            End If
'            If j = XRow - 1 Then
'                XArr8(i, 1) = 0
'                XArr8(i, 2) = 0
'                XArr8(i, 3) = 0
'                XArr8(i, 4) = 0
'            End If
        Next
    Next
    Worksheets("VenteSurDern4Semaines").Range(QT & ":" & NextDeliv & EndRow + 2).Value = XArr8
    Erase XArr6
    Erase XArr7
    Erase XArr8
End Function
Function LinesVente()
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Function
Sub VenteSur()
    t = Timer
    Dim XArr() As Variant
    Dim XArr2() As Variant
    Dim XArr3() As Variant
    Dim XArr4() As Variant
    Dim XArr5() As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Worksheets("VenteSurDern4Semaines").Select
    Worksheets("VenteSurDern4Semaines").Rows("3:3").Select
    Worksheets("VenteSurDern4Semaines").Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ChDir "Путь к файлу"
    Workbooks.Open Filename:="Путь к файлу\VenteSurDern4Semaines012.xls"
    Workbooks("VenteSurDern4Semaines012.xls").Activate
    Worksheets("VenteSurDern4Semaines012").Copy Before:=Workbooks("VenteSur012.xlsm").Sheets(1)
    Workbooks("VenteSurDern4Semaines012.xls").Close SaveChanges:=False
    Workbooks("VenteSur012.xlsm").Activate
    
    Worksheets("VenteSurDern4Semaines012").Select
    Dim XRow As Long
    XRow = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    ReDim XArr(1 To XRow - 1, 1 To 11) As Variant
    XArr = Worksheets("VenteSurDern4Semaines012").Range("C2:M" & XRow).Value
    Worksheets("VenteSurDern4Semaines012").Select
    ActiveWindow.SelectedSheets.Delete
    Worksheets("VenteSurDern4Semaines").Select
    Worksheets("VenteSurDern4Semaines").Range("A3:A" & XRow + 1).Value = Application.Index(XArr, 0, 1)
    Worksheets("VenteSurDern4Semaines").Range("B3:B" & XRow + 1).Value = Application.Index(XArr, 0, 4)
    Worksheets("VenteSurDern4Semaines").Range("C3:C" & XRow + 1).Value = Application.Index(XArr, 0, 5)
    Worksheets("VenteSurDern4Semaines").Range("D3:D" & XRow + 1).Value = Application.Index(XArr, 0, 11)
    Worksheets("VenteSurDern4Semaines").Range("I3:I" & XRow + 1).Value = Application.Index(XArr, 0, 6)
    Worksheets("VenteSurDern4Semaines").Range("J3:J" & XRow + 1).Value = Application.Index(XArr, 0, 8)
    ReDim XArr2(1 To XRow - 1, 1 To 5) As Variant
    For i = 1 To XRow - 1
        Dat = XArr(i, 9)
        Dat2 = XArr(i, 10)
        Dat3 = XArr(i, 8)
        Dat4 = XArr(i, 6)
        If Dat = 0 Then
            XArr2(i, 1) = Dat
        Else
            XArr2(i, 1) = Right(Dat, 2) & "." & Mid(Dat, 3, 2) & "." & Left(Dat, 2)
        End If
        If Dat2 = 0 Then
            XArr2(i, 2) = Dat2
        Else
            XArr2(i, 2) = Right(Dat2, 2) & "." & Mid(Dat2, 3, 2) & "." & Left(Dat2, 2)
        End If
        If Dat4 = 0 Then
            XArr2(i, 3) = 0
        Else
            Dat5 = Dat3 / (Dat4 / 28)
            XArr2(i, 3) = CSng(Dat5)
        End If
    Next
    Worksheets("VenteSurDern4Semaines").Range("E3:E" & XRow + 1).Value = Application.Index(XArr2, 0, 1)
    Worksheets("VenteSurDern4Semaines").Range("F3:F" & XRow + 1).Value = Application.Index(XArr2, 0, 2)
    Worksheets("VenteSurDern4Semaines").Range("K3:K" & XRow + 1).Value = Application.Index(XArr2, 0, 3)
    Worksheets("VenteSurDern4Semaines").Select
    Worksheets("VenteSurDern4Semaines").Range("A3:AU" & XRow + 1).Select
    Call LinesVente
    Worksheets("VenteSurDern4Semaines").Range("I3:K" & XRow + 1).Select
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
    Worksheets("VenteSurDern4Semaines").Range("E3:H" & XRow + 1).Select
    With Selection.Interior
        .ColorIndex = 38
        .Pattern = xlSolid
    End With
    ReDim XArr3(1 To 106, 1 To 3) As Variant
    ReDim XArr4(1 To XRow - 1, 1 To 2) As Variant
    ReDim XArr5(1 To XRow - 1, 1) As Variant
    XArr3 = Worksheets("Eeno1").Range("A1:C106").Value
    For i = 1 To XRow - 1
        For j = 1 To 106
            If CStr(XArr3(j, 1)) = XArr(i, 1) Then
                XArr4(i, 1) = XArr3(j, 2)
                XArr4(i, 2) = XArr3(j, 3)
                Exit For
            End If
        Next
        XArr5(i, 1) = XArr(i, 4)
    Next
    Worksheets("VenteSurDern4Semaines").Range("G3:G" & XRow + 1).Value = Application.Index(XArr4, 0, 1)
    Worksheets("VenteSurDern4Semaines").Range("H3:H" & XRow + 1).Value = Application.Index(XArr4, 0, 2)
    
    Erase XArr
    Erase XArr2
    Erase XArr3
    Erase XArr4
    ReDim Preserve XArr5(1 To XRow - 1, 1) As Variant
    Call VenteSur_Func(XArr5, "001", "L3", "O", XRow - 1)
    Call VenteSur_Func(XArr5, "002", "P3", "S", XRow - 1)
    Call VenteSur_Func(XArr5, "003", "T3", "W", XRow - 1)
    Call VenteSur_Func(XArr5, "007", "X3", "AA", XRow - 1)
    Call VenteSur_Func(XArr5, "009", "AB3", "AE", XRow - 1)
    Call VenteSur_Func(XArr5, "010", "AF3", "AI", XRow - 1)
    Call VenteSur_Func(XArr5, "011", "AJ3", "AM", XRow - 1)
'    Call VenteSur_Func(XArr5, "015", "AN3", "AQ", XRow - 1)
'    Call VenteSur_Func(XArr5, "016", "AR3", "AU", XRow - 1)
    Worksheets("VenteSurDern4Semaines").Range("A1").Select
    Worksheets("VenteSurDern4Semaines").Range("C1") = Format(Timer - t, HH.mm.ss)
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub