Question

我一直在尝试开发一个例程，它将从Access数据库中突出显示Excel中某个范围的每一行。

这消除了许多关于该主题的不同代码产品，因为大多数利用了嵌入式Excel功能。

下面的代码是我一直用于测试的Access VBA的独立提取，希望我能找到正确的参数结构来使其工作。因此，代码包括一些Dim语句等，如果我将此宏直接嵌入Excel宏中则不需要。

我已经完成了所有其他行的选择，但出于某种原因，只有预期范围的第一列。我无法解决此问题，并在格式化过程中包含其他列。

非常感谢任何帮助。

Sub xxx()
Dim xlbook As Excel.Workbook
Dim xlRng As Range
Dim xlFinalRange As Range
Dim intColumnCount As Integer
Dim introwcount As Integer
Dim strTable As String

Set xlbook = Excel.ThisWorkbook

strTable = "Sheet1"
introwcount = 20
intColumnCount = 14


Set xlFinalRange = Sheets(strTable).Range("A4")
xlFinalRange.Resize(1, intColumnCount).Select
Set xlRng = Sheets(strTable).Range("A4")
xlRng.Resize(1, intColumnCount).Select
intRowsBetween = 2

For i = 0 To introwcount
    Set xlRng = xlRng.Offset(intRowsBetween, 0)
    xlRng.Resize(1, intColumnCount).Select
    Set xlFinalRange = xlbook.Application.Union(xlFinalRange, xlRng)
    xlFinalRange.Resize(1, intColumnCount).Select
    i = i + (intRowsBetween - 1)
Next i

xlFinalRange.Select

    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

End Sub

Answer 1

最好的方法是在循环中添加适当的Step。此外，正确评估所有内容：Range应为Excel.Range等。请尝试以下操作：

Sub HighlightXL()

    Dim WBK As Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim Iter As Long
    Dim CombinedRng As Excel.Range, IterRng As Excel.Range

    Excel.Application.Visible = True
    Set WBK = Excel.Workbooks.Add 'Modify as necessary.
    Set WS = WBK.Sheets("Sheet1") 'Modify as necessary.

    With WS
        For Iter = 1 To 22 Step 3 '1, 4, 7, 9... etc...
            Set IterRng = .Cells(Iter, 1).Resize(1, 5) 'Resize to 14 in your case.
            If CombinedRng Is Nothing Then
                Set CombinedRng = IterRng
            Else
                Set CombinedRng = Union(CombinedRng, IterRng)
            End If
        Next Iter
    End With

    CombinedRng.Interior.ColorIndex = 3 'Red.

End Sub

<强>截图：

enter image description here

如果有帮助，请告诉我们。：）

Answer 2

我过去采取了略微不同的方法。以下是我将要使用的内容：

Sub ColourSheet()

Dim ApXL As Object, xlWBk As Object, xlWSh As Object, _
    rng As Object, c As Object
Dim strSheet As String, strFile As String
Dim iColourRow As Integer, iRows As Integer, _
    iCols As Integer, x As Integer, iStartRow As Integer

strFile = "C:\YourFolder\YourFile.xlsx"
strSheet = "SheetName"

iColourRow = 3
iRows = 30
iCols = 10
iStartRow = 2

If SmartGetObject("Excel.Application") Then
    'excel open
    Set ApXL = GetObject(, "Excel.Application")
Else
    Set ApXL = CreateObject("Excel.Application")
End If

Set xlWBk = ApXL.Workbooks.Add
'Set xlWBk = ApXL.Workbooks.Open(strFile)

Set xlWSh = xlWBk.activesheet
'Set xlWSh = xlWBk.Worksheets(strSheet)

For x = 1 To iRows
    If x Mod iColourRow = 0 Then
        With xlWSh.range(xlWSh.cells(iStartRow + x - 1, 1), _
            xlWSh.cells(iStartRow + x - 1, iCols)).interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            '.ThemeColor = xlThemeColorAccent1
            .Color = 255
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
    End If
Next x

ApXL.Visible = True

End Sub

一些注意事项：

特别是如果您计划分发数据库，我建议使用后期绑定来引用Excel，如果您迟早使用VBA引用，某人的数据库将停止工作，您将得出结论，这是由于缺少引用。搜索后期绑定，你会看到很多关于这个主题。请注意，对于后期绑定，您不会获得xlThemeColorAccent1等变量，您始终可以通过打开Excel VBA实例等来获取这些变量。

我使用了一个函数调用GetSmartObject来识别你是否已经运行了Excel，我遇到的一个问题是打开其他Excel实例，遇到错误，然后该实例仍然在后台运行，你需要进入任务管理器关闭它。

最后，我刚刚注释掉备用工作簿，打开指定文件并设置工作表，测试它更容易打开新工作簿并使用活动工作表。

希望这有帮助

Function SmartGetObject(sClass As String) As Integer
      Dim oTmpObject As Object

      ' If Server running, oTmpObject refers to that instance.
      ' If Server not running Error 429 is generated.
      On Error Resume Next
      Set oTmpObject = GetObject(, sClass)
      ' oTmpObject is reference to new object.
      If Err = 429 Then
        SmartGetObject = False
        Exit Function
         ' Server not running, so create a new instance:
         'Simon noted out: Set oTmpObject = GetObject("", sClass)
         ' NOTE: for Excel, you can add the next line to view the object
         ' oTmpObject.Visible = True
      ElseIf Err > 0 Then
         MsgBox Error$
         SmartGetObject = False
         Exit Function
      End If
      Set oTmpObject = Nothing
      SmartGetObject = True
End Function

上述功能的功劳属于其他地方，但我已经有了这么长时间，我不知道它来自哪里，如果有人能告诉我，我将来会正确归功。

Answer 3

    Option Compare Database

选项明确

Sub ExporttoExcel（）

Dim i As Integer
Dim y As Integer
Dim varArray As Variant         'Used for obtaining the Names of the Sheets from the DB being exported
Dim varField As Variant         'Used for Naming of the Sheets being exported
Dim dbs As DAO.Database
Dim rst1 As DAO.Recordset       'DB Recordset for the Input and Output information
Dim rst2 As DAO.Recordset       'DB Recordset for the Table names to be exported and sheet names in Excel
Dim rst3 As DAO.Recordset       'DB Recordset that is reused for each Table being exported
Dim strFile As String           'Used for the name and location of the Excel file to be saved
Dim strTable As String          'Table name being exported and also used for the Sheet name
Dim strTitle As String          'Title for the Data on each sheet
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlRunning As Boolean        'Flag to identify that Excel is running or not
Dim intColumnCount As Integer   'The number of columns on a sheet for formatting
Dim intRowCount As Integer      'The number of rows on a sheet for formatting
Dim intStartRow As Integer      'The row from which to start the highlighting process
Dim intRowsBetween As Integer   'The number of rows between highlighting


If SmartGetObject("Excel.Application") Then
    Set xlApp = GetObject(, "Excel.Application")    'Excel is already open so the existing instance will be used
    xlRunning = True
Else
    Set xlApp = CreateObject("Excel.Application")   'Excel is not open so an instance will be created
    xlRunning = False
End If

Set xlBook = xlApp.Workbooks.Add

xlApp.Visible = True

xlApp.DisplayAlerts = False

Set dbs = CurrentDb

'Retrieve Study Location and Name for Import to Database

Set rst1 = dbs.OpenRecordset("StudyTarget")
strFile = rst1!OutputFile
' Removed VBA for File Name & Save Path Information
 With xlBook
    Set rst2 = dbs.OpenRecordset("ExportTableGroup", dbOpenSnapshot)
    ' Removed VBA for Excel Naming information from DB

    For y = 0 To rst2.RecordCount - 1

        strTable = varArray(y, 1)
        strTitle = varArray(y, 2)

        Set rst3 = dbs.OpenRecordset(strTable, dbOpenTable)
        .Sheets.Add after:=Sheets(Sheets.Count)
        .Sheets(Sheets.Count).Name = strTable
        Set xlSheet = .ActiveSheet

    'COPY the Access Table Data to the Named Worksheet

        xlSheet.Cells(2, 1).CopyFromRecordset rst3

     'Select every X number of rows between sheet Data Rows on Worksheet to highlight

        intRowsBetween = 2
        intStartRow = 4

        For i = 0 To intRowCount Step intRowsBetween
            If xlSheet.Cells(intStartRow + i, 1) = "" Then
                Exit For
            End If
            With xlSheet.Range(xlSheet.Cells(intStartRow + i, 1), _
                               xlSheet.Cells(intStartRow + i, intColumnCount)).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = RGB(186, 186, 186)
                .TintAndShade = 0.6
                .PatternTintAndShade = 0
            End With

        Next i      'Next Row

    Next            'Next Table

    .Sheets("sheet1").Delete
    .Sheets(1).Select           'Go to first sheet of workbook

End With

Export_to_Excel_Exit:

rst1.Close
rst2.Close
rst3.Close

xlApp.ActiveWorkbook.Save
xlBook.Close
If xlRunning Then           'Check to see if used an existing instance of Excel via SmartGetObject
Else
    xlApp.Quit
    Set xlApp = Nothing
End If
Set xlBook = Nothing
Set rst1 = Nothing
Set rst2 = Nothing
Set rst3 = Nothing

Set dbs = Nothing

Exit Sub

使用Access DB中的VBA突出显示交替的Excel工作表行

3 个答案: