ExcelにエクスポートしてAccess VBAでExcelをフォーマットする - .Range Error

Question

私は今数日間この作業をしており、インターネット上で多くのことを読んでいます。今は盲目で、髪が残っていません。ソリューションに非常に近いですが、必然的に助けが必要です。

テーブルからデータを取得するためにクエリを作成したAccessデータベースがあります。私はボタンをクリックして複数のシートを持つExcelにエクスポートするフォームを作った。

私は書式を設定してエクスポートしようとしていますが、マクロがVBAに変換されていますが、どのように処理されるのかはわかりますが、複数のシートを含むブックを作成し、 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にデータをエクスポートしますが、私はそれに追加する方法がわかりません複数のシートを作成したり（他のクエリを呼び出すことによって）、日付Fを条件付きでフォーマットして、セルを赤にします14日齢以上。

このコードは、複数のシートを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