Question

嘿那些伙计所以我正在研究一个工作项目，我已经完成了一些格式化的数据但是我不知道如何在Access vba中为excel进行条件格式化。但代码必须在数据库中，因为最终人们将能够选择自己的文件位置。但这是另一个问题。正在考虑使用函数在代码的主要部分下看到（在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 down那一排。

您需要提供正确的路径名并取消注释工作表选择代码。

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

使用Access（图标集）中的条件格式将表格从Access导出到Excel

1 个答案: