Модуль iFunction

Option Explicit
Public CN As ADODB.Connection, RS As ADODB.Recordset



Function SearchData(ByVal iSTR As Variant) As Long
    On Error Resume Next
    SearchData = 0: If VBA.Trim(iSTR) = "" Then Exit Function
    SearchData = WorksheetFunction.Match(iSTR, Sheets("сводная").Range("G:G").Value, 0)
End Function


Function TransposeArray(ByVal arr As Variant) As Variant
    Dim tempArray As Variant, x As Long, y As Long
    ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For x = LBound(arr, 2) To UBound(arr, 2)
        For y = LBound(arr, 1) To UBound(arr, 1)
            tempArray(x, y) = arr(y, x)
        Next y
    Next x
    TransposeArray = tempArray
End Function


Function ЦветЗаливки(Ячейка As Range) As Double
    ЦветЗаливки = Ячейка.Interior.Color
End Function


Function CheckName(ByVal iCol As Integer) As String
    Select Case iCol
        Case 9: CheckName = "СЧЕТ_РСБУ"
        Case 10: CheckName = "СЧЕТ_МСФО"
        Case 11: CheckName = "ДАТА_ДОКУМЕНТА"
        Case 12: CheckName = "СУММА_RUR"
    End Select
End Function


Sub ConnectOpen()
    Set CN = New ADODB.Connection
    CN.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & """" & Sheets("макрос").Range("ПутькБазе").Value & """" & "; Persist Security Info=False;"
    'CN.Mode = adModeRead            'режим подключения
    CN.CommandTimeout = 600
    CN.Open
End Sub
Sub InsertBase(ByVal iTime As Date, ByVal iUser As String, ByVal iPath As String, ByVal iFileName As String, ByVal s1 As String, ByVal s2 As String, ByVal s3 As String, ByVal s4 As String, ByVal s5 As String)
    Dim iSQL As String
    iSQL = "INSERT INTO LOGS (STIME, USER_NAME, PATH, FILE_NAME, BAN, ORG_NAME, PARAMETER, OLD_VALUE, NEW_VALUE)" & vbCrLf & _
           "VALUES('" & iTime & "', '" & iUser & "', '" & iPath & "', '" & iFileName & "', '" & s1 & "', '" & s2 & "', '" & s3 & "', '" & s4 & "', '" & s5 & "')"
    CN.Execute iSQL
End Sub
Sub SelectHistory()
    Dim iArray() As Variant, iSQL As String, iBAN As String, iParameter As String
    On Error Resume Next: Err.Clear

    If ActiveSheet.Name = "сводная" And (ActiveCell.Column >= 9 And ActiveCell.Column <= 12) Then
        iBAN = ActiveSheet.Cells(ActiveCell.Row, 7).Value: iParameter = ActiveSheet.Cells(1, ActiveCell.Column).Value

        Call ConnectOpen: Set RS = New ADODB.Recordset

        iSQL = "select * from LOGS where BAN = '" & iBAN & "' and PARAMETER = '" & iParameter & "'"
        RS.Open iSQL, CN
        iArray = RS.GetRows

        RS.Close: Set RS = Nothing
        CN.Close: Set CN = Nothing

        If Err.Number <> 0 Then
            MsgBox "По указанной ячейке история отсутствует.", vbInformation: Exit Sub
        End If

        iArray = TransposeArray(iArray)
        With Sheets("история ячейки")
            If .FilterMode = True Then .ShowAllData: .AutoFilter.Sort.SortFields.Clear
            .Cells.ClearContents
            .Range(.Cells(2, 1), .Cells(UBound(iArray, 1) + 2, 9)).Value = iArray
            .Range("A1:I1") = Array("STIME", "USER_NAME", "PATH", "FILE_NAME", "BAN", "ORG_NAME", "PARAMETER", "OLD_VALUE", "NEW_VALUE")
            If .AutoFilterMode = False Then .Range("A1").AutoFilter
            .Activate: .Cells(1, 10).Activate
        End With
    Else
        MsgBox "Выбранная ячейка должна располагаться в диапазоне столбцов: от I до L (включительно).", vbInformation
    End If
End Sub