Модуль iModule

Option Explicit



Sub TestData()
    Dim rNew, rSource, rUpdate, rColor
    Dim iWB As Workbook, rTemp, iRow As Long, i As Long, j As Long, k As Long, n As Long, x As Long
    Dim iTime As Date, iUser As String, iPath As String, iFileName As String

    Application.ScreenUpdating = 0
    Call ConnectOpen

    'формируем константы для записи в лог
    iTime = Now: iUser = Environ("username")
    iPath = Sheets("макрос").Range("ПутькФайлу").Value: iFileName = Right(iPath, Len(iPath) - InStrRev(iPath, "\"))

    'формируем массив из файла "Обновленные данные.xlsx"
    Set iWB = Workbooks.Open(iPath, UpdateLinks:=False, ReadOnly:=True)
    With iWB.Sheets("данные")
        If .FilterMode = True Then .ShowAllData: .AutoFilter.Sort.SortFields.Clear
        iRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        rNew = .Range(.Cells(2, 1), .Cells(iRow, 12)).Value
    End With
    iWB.Close False: Set iWB = Nothing

    'формируем массив из файла "Основной файл.xlsm"
    With ThisWorkbook.Sheets("сводная")
        If .FilterMode = True Then .ShowAllData: .AutoFilter.Sort.SortFields.Clear
        iRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        rSource = .Range(.Cells(2, 1), .Cells(iRow, 12)).Value
        .Range(.Cells(2, 1), .Cells(iRow, 12)).Interior.Pattern = xlNone
    End With

    'формируем массив для обновленных значений, изначально равен исходному
    rUpdate = rSource: rUpdate = TransposeArray(rUpdate)

    'формируем массив для цветовых значений, изначально пустой
    ReDim rColor(1 To 1): rColor(1) = ""

    'проверяем наличие новых поставщиков
    For i = 1 To UBound(rNew, 1)
        If VBA.Trim(rNew(i, 7)) = "" Then GoTo STEP_1
        x = SearchData(rNew(i, 7))

        If x = 0 Then
            'если номер договора не найден в сводном отчете, то:
            '1) в массив rUpdate добавляем новую строку, 2) в массиве rColor фиксируем изменение цвета
            n = n + 1: If n > 1 Then ReDim Preserve rColor(1 To n)

            k = UBound(rUpdate, 2) + 1: ReDim Preserve rUpdate(1 To 12, 1 To k)
            For j = 1 To 12: rUpdate(j, k) = rNew(i, j): Next j
            rColor(n) = "5296274;A" & k + 1 & ":L" & k + 1

            'пишем лог в базу
            Call InsertBase(iTime, iUser, iPath, iFileName, rNew(i, 7), rNew(i, 8), "СЧЕТ_РСБУ", "", rNew(i, 9))
            Call InsertBase(iTime, iUser, iPath, iFileName, rNew(i, 7), rNew(i, 8), "СЧЕТ_МСФО", "", rNew(i, 10))
            Call InsertBase(iTime, iUser, iPath, iFileName, rNew(i, 7), rNew(i, 8), "ДАТА_ДОКУМЕНТА", "", rNew(i, 11))
            Call InsertBase(iTime, iUser, iPath, iFileName, rNew(i, 7), rNew(i, 8), "СУММА_RUR", "", rNew(i, 12))
        Else
            'если номер договора уже присутствует в сводном отчете, то проверяем изменились ли наши контрольные ячейки
            For j = 9 To 12
                If rSource(x - 1, j) <> rNew(i, j) Then
                    'пишем лог в базу
                    Call InsertBase(iTime, iUser, iPath, iFileName, rNew(i, 7), rNew(i, 8), CheckName(j), rUpdate(j, x - 1), rNew(i, j))

                    'осуществляем подставноку значений
                    rUpdate(j, x - 1) = rNew(i, j)
                    n = n + 1: If n > 1 Then ReDim Preserve rColor(1 To n)
                    rColor(n) = "65535;" & Split(Cells(1, j).Address, "$")(1) & x
                End If
            Next j
        End If

STEP_1:
    Next i

    'вставляем массив rUpdate на лист, если есть измененные данные
    If rColor(1) <> "" Then
        rUpdate = TransposeArray(rUpdate)
        With ThisWorkbook.Sheets("сводная")
            'вставляем данные на лист
            .Range(.Cells(2, 1), .Cells(UBound(rUpdate, 1) + 1, 12)).Value = rUpdate

            'форматируем новые строки по аналогии с первой строкой данных
            .Range("A2:L2").Copy
            .Range(.Cells(2, 1), .Cells(UBound(rUpdate, 1) + 1, 12)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False: .Activate: .Cells(1, 1).Activate
        End With

        'задаем цвета измененным ячейкам
        For i = 1 To UBound(rColor, 1)
            rTemp = Split(rColor(i), ";")
            ThisWorkbook.Sheets("сводная").Range(rTemp(1)).Interior.Color = rTemp(0)
        Next i
    End If


    'добавить историю изменений, чтобы смотреть при клике по ячейке

    CN.Close: Set CN = Nothing
    Application.ScreenUpdating = 1

    MsgBox "Работа макроса завершена", vbInformation
End Sub