通過Access VBA導出並格式化Excel-.Range錯誤

Question

我已經為此工作了幾天，在互聯網上讀了很多東西，我現在是盲人，沒有頭發了。 非常接近解決方案，但迫切需要幫助。

我有一個Access數據庫，我進行了一些查詢以從表中檢索數據。 我制作了一個帶有按鈕的表單，單擊可單擊以導出到具有多個工作表的Excel。

我正在嘗試使用格式導出，並查看如何完成該操作，然后將宏轉換為Vb，看到了如何完成操作，但是我無法使代碼創建具有多個工作表的工作簿，並向F列添加一些條件格式。

將以訪問表格式導出到Excel的代碼如下所示：

Private Sub Advance_Waiting_on_Visual_Report_Click()
On Error GoTo Advance_Waiting_on_Visual_Report_Click_Err

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
Dim strFileName As String
strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.OutputTo acOutputQuery, "AdvanceWaitVis", "ExcelWorkbook(*.xlsx)", strFileName, True, "AdvanceWaitVis", , acExportQualityPrint

Advance_Waiting_on_Visual_Report_Click_Exit:
Exit Sub

Advance_Waiting_on_Visual_Report_Click_Err:
MsgBox Error$
Resume Advance_Waiting_on_Visual_Report_Click_Exit

End Sub`

這將以Access表格式將數據導出到Excel，但是我不知道如何添加數據以使其能夠處理多個工作表（通過調用其他查詢），或者如果日期為14天，則不會有條件地格式化F列以使單元格變為紅色年齡更大或更老。

此代碼將導出到具有多個工作表的Excel，但不會傳輸Access表格式並掛在行上

.Range("F1:F" & lngRow).Select

並且由於該掛起，它不會設置該行之后代碼中列出的條件格式。

Code in Module named ExportFormatting


Public Function fnLastRow(sh As Object)
On Error Resume Next
With sh
fnLastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=2, _
LookIn:=5, _
SearchOrder:=1, _
SearchDirection:=2, _
MatchCase:=False).row
End With
End Function


Code for button


Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
Dim strFileName As String
strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

Dim xlWB As Object
Dim xlObj As Object
Dim xlSheet As Object
Dim lngRow As Long

Set xlObj = CreateObject("Excel.Application")

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

For Each xlSheet In xlWB.Worksheets

With xlSheet

lngRow = fnLastRow(xlSheet)
Debug.Print lngRow

.Range("F1:F" & lngRow).Select
xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                "=TODAY()-F1<13"
  xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
With xlObj.Selection.FormatConditions(1).Interior
.PatternColorIndex = -4105
.Color = 255
.TintAndShade = 0
End With
xlObj.Selection.FormatConditions(1).StopIfTrue = False

End With

Next
xlWB.Close True
Set xlSheet = Nothing
Set xlWB = Nothing
xlObj.Quit
Set xlObj = Nothing

End Sub

有人可以幫我解決此代碼嗎？

Answer 1

您不能在不是ActiveSheet的圖紙上選擇范圍，在任何情況下都不需要選擇：

Dim rng As Object

'...

lngRow = fnLastRow(xlSheet)
Debug.Print lngRow

Set rng = xlSheet.Range("F1:F" & lngRow)
rng.FormatConditions.Add Type:=2, Formula1:= _
                "=TODAY()-F1<13"
rng .FormatConditions(xlObj.Selection.FormatConditions.Count) _
           .SetFirstPriority

With rng.FormatConditions(1).Interior
    .PatternColorIndex = -4105
    .Color = 255
    .TintAndShade = 0
End With

rng.FormatConditions(1).StopIfTrue = False

Answer 2

現在的代碼看起來像這樣

Private Sub Command35_Click()

Const FileNameBase As String = "W:\Quality-Projects\RCabler\Databases\Weekly Reports\Waiting on Visual Weekly Report [CurrentDate].xlsx"
Dim strFileName As String
strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "AdvanceWaitVis", strFileName, True, "AdvanceWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "ArcadiaWaitVis", strFileName, True, "ArcadiaWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "EcruWaitVis", strFileName, True, "EcruWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "LeesportWaitVis", strFileName, True, "LeesportWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "RipleyWaitVis", strFileName, True, "RipleyWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanekWaitVis", strFileName, True, "WanekWaitVis"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "WanvogWaitVis", strFileName, True, "WanvogWaitVis"

Dim rng As Object
Dim xlWB As Object
Dim xlObj As Object
Dim xlSheet As Object
Dim lngRow As Long

Set xlObj = CreateObject("Excel.Application")

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

For Each xlSheet In xlWB.Worksheets

    With xlSheet


        lngRow = fnLastRow(xlSheet)
        Debug.Print lngRow

        Set rng = xlSheet.Range("F1:F" & lngRow)
rng.FormatConditions.Add Type:=2, Formula1:= _
            "=TODAY()-F1<13"
rng .FormatConditions(xlObj.Selection.FormatConditions.Count) _
       .SetFirstPriority

With rng.FormatConditions(1).Interior
.PatternColorIndex = -4105
.Color = 255
.TintAndShade = 0
End With

rng.FormatConditions(1).StopIfTrue = False

End With

Next
xlWB.Close True
Set xlSheet = Nothing
Set xlWB = Nothing
xlObj.Quit
Set xlObj = Nothing

End Sub