使用Access中的條件格式將表從Access導出到Excel（圖標集）

Question

大家好，所以我正在做一個工作項目，並且我已經對數據進行了一些格式化，但是我不知道如何在Excel的Access vba中進行條件格式化。 但是代碼必須在數據庫中，因為最終人們將能夠選擇自己的文件位置。 但這是另一個問題。 正在考慮使用函數，請參見代碼主要部分（結束於End Sub）。 不知道什么會更好地工作或嘗試在循環中執行

Public Sub ModifyExportedExcelFileFormats(sFile As String)
On Error GoTo Err_ModifyExportedExcelFileFormats

Dim xlApp As Object
Dim xlSheet As Object
Dim x1Rng As Object

Set xlApp = CreateObject("Excel.Application")
Set xlSheet = xlApp.Workbooks.Open(sFile).Sheets("Full_List")

 With xlApp
        .Application.Sheets("Full_List").Select
        .Application.Cells.Select
        .Application.Selection.ClearFormats
        .Application.Rows("1:1").Select
        .Application.Selection.Font.Bold = True
        .Application.Selection.Interior.ColorIndex = 41
        .Application.Selection.RowHeight = 38.25
        .Application.Selection.Font.ColorIndex = 2
        .Application.Selection.VerticalAlignment = xlCenter
        .Application.ActiveWorkbook.Save
        .Application.ActiveWorkbook.Close
        .Quit
End With

Set xlApp = Nothing
Set xlSheet = Nothing

vStatusBar = SysCmd(acSysCmdClearStatus)

Exit_ModifyExportedExcelFileFormats:

Exit Sub

Err_ModifyExportedExcelFileFormats:
vStatusBar = SysCmd(acSysCmdClearStatus)
MsgBox Err.Number & " - " & Err.Description
Resume Exit_ModifyExportedExcelFileFormats

End Sub

Public Function GetCelColor(ByRef CelVal As Long) As Long
Select Case True

Case CelVal = 1: GetCelColor = RGB(222, 0, 0): Exit Function
Case CelVal < 1: GetCelColor = RGB(0, 111, 0): Exit Function
Case CelVal > 1: GetCelColor = RGB(0, 0, 255): Exit Function
End Function

再次感謝所有回復的人

Answer 1

如果您使用的是Excel條件格式交通信號燈圖標集，則無需設置顏色。

此代碼使用后期綁定，因此無需設置對Excel的引用。

編輯：閱讀您的評論后，我添加了LastCell函數，以便它將在工作表上找到包含數據的最后一個單元格，並將條件格式添加到該行的A：M列中。

您需要提供正確的路徑名，並取消注釋工作表選擇代碼。

Public Sub Test()

    Main "S:\Book3.xlsx"

End Sub

Public Sub Main(sFile)

    Dim oXL As Object
    Dim oWrkBk As Object
    Dim owrkSht As Object

    Set oXL = CreateXL
    Set oWrkBk = oXL.workbooks.Open(sFile)
    'Set oWrkSht = oWrkBk.worksheets("Full_List")

    'Testing
    'Set oWrkBk = oXL.workbooks.Add
    Set owrkSht = oWrkBk.worksheets(1)

    With owrkSht
        .cells.clearformats
        With .rows("1:1")
            With .Font
                .Bold = True
                .colorindex = 2
            End With
            .Interior.colorindex = 41
            .RowHeight = 38.25
            .verticalalignment = -4108 'xlCenter
        End With

        With .Range(.cells(2, 2), .cells(LastCell(owrkSht).row, 13))

            'Clear any conditional formatting first.
            'This won't need doing if the workbook is new.
            .FormatConditions.Delete

            .FormatConditions.AddIconSetCondition
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1)
                .ReverseOrder = False
                .ShowIconOnly = False
                .IconSet = oWrkBk.IconSets(4) 'xl3TrafficLights1
                With .IconCriteria(2)
                    .Type = 0 'xlConditionValueNumber
                    .Value = 2
                    .Operator = 7
                End With
                With .IconCriteria(3)
                    .Type = 0 'xlConditionValueNumber
                    .Value = 4
                    .Operator = 7
                End With
            End With

        End With
    End With

    With oWrkBk
        .Save
        .Close
    End With

End Sub

Public Function LastCell(wrkSht As Object, Optional Col As Long = 0) As Object

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .cells.Find("*", , , , 2, 2).Column
            lLastRow = .cells.Find("*", , , , 1, 2).row
        Else
            lLastCol = .cells.Find("*", , , , 2, 2).Column
            lLastRow = .Columns(Col).Find("*", , , , 2, 2).row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Public Function CreateXL(Optional bVisible As Boolean = True) As Object

    Dim oTmpXL As Object

    On Error Resume Next
    Set oTmpXL = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo ERROR_HANDLER
        Set oTmpXL = CreateObject("Excel.Application")
    End If

    oTmpXL.Visible = bVisible
    Set CreateXL = oTmpXL

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateXL."
            Err.Clear
    End Select

End Function