☰

通过寻址范围返回范围内单元格的值

tag-icon • tag-icon microsoft-excel vba
通过寻址范围返回范围内单元格的值

我有两列 Excel 名称 Days 和 Ref，我有一些 VBA 可以减少 Days，如果天数少于 730，它会将单元格突出显示为绿色，我还想要该行的 Ref 列中的 ref，它在 A 列中。我不想使用 OFFSET 来获取值，因为列可能会更改，有没有办法使用 Ref 命名范围来获取 Ref 值？或者其他方法。

我使用的代码是

Sub Days()

    Dim myDaysRange As Range
    Dim myDays As Range

    Set myDaysRange = Selection
    
    For Each myDays In myDaysRange
    
        If myDays.Value < 730 Then
            
            myDays.Interior.ColorIndex = 36
            'Here I also want the Ref value from Col A of the same row without referring to Col A but the named range "Ref" in case the column order changes.


        End If
        
    Next myDays
    
End Sub

答案1

强调

  • 调整常量部分的值后，通过将使用的范围（表格）移动到整个工作表来测试代码的准确性。
Option Explicit

Sub HighlightDaysAndRef()

    ' Both
    Const wsName As String = "Sheet1"
    Const cColor As Long = vbGreen
    ' Source
    Const sHeader As String = "Days"
    Const sCriteria As Double = 730
    ' Destination
    Const dHeader As String = "Ref"
    
    ' Workbook, Worksheet
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    ' Create a reference to the Used Range ('urg').
    Dim urg As Range: Set urg = ws.UsedRange
    Dim urCount As Long: urCount = urg.Rows.Count
    If urCount = 1 Then Exit Sub
    Dim cCount As Long: cCount = urg.Columns.Count
    
    ' Create a reference to the Source Header Cell ('shCell').
    Dim shCell As Range
    Set shCell = urg.Find(sHeader, urg.Cells(urCount, cCount), _
        xlFormulas, xlWhole, xlByRows)
    If shCell Is Nothing Then
        MsgBox "Could not find the '" & sHeader & "' header.", _
            vbCritical, "Header Not Found"
        Exit Sub
    End If
    
    ' Create a reference to the Source Column Range ('scrg').
    Dim hRow As Long: hRow = shCell.Row
    Dim ufRow As Long: ufRow = urg.Row
    Dim rOff As Long: rOff = hRow - ufRow
    Dim trg As Range: Set trg = urg.Resize(urCount - rOff).Offset(rOff)
    Dim scrg As Range: Set scrg = Intersect(trg, shCell.EntireColumn)
    
    ' Write the Destination Header Column to a variable ('dcol').
    Dim hrrg As Range: Set hrrg = trg.Rows(1)
    Dim dhCell As Range
    Set dhCell = hrrg.Find(dHeader, hrrg.Cells(cCount), _
        xlFormulas, xlWhole)
    If dhCell Is Nothing Then
        MsgBox "Could not find the '" & dHeader & "' header.", _
            vbCritical, "Header Not Found"
        Exit Sub
    End If
    Dim dCol As Long: dCol = dhCell.Column
    
    ' Combine cells to highlight into the Highlight Range ('hlrg').
    Dim hlrg As Range
    Dim sCell As Range
    Dim sValue As Variant
    For Each sCell In scrg.Cells
        sValue = sCell.Value
        If IsNumeric(sValue) Then
            If sValue < sCriteria Then
                Set hlrg = GetCombinedRange(hlrg, Union( _
                    sCell, sCell.EntireRow.Columns(dCol)))
            End If
        End If
    Next sCell
    
    ' Remove hightlights.
    Union(scrg, scrg.EntireRow.Columns(dCol)).Interior.Color = xlNone
    
    ' Highlight the desired cells.
    If hlrg Is Nothing Then
        MsgBox "Nothing to highlight.", vbExclamation, "Highlight"
        Exit Sub
    End If
    hlrg.Interior.Color = cColor
    
    ' Inform of success.
    MsgBox "Cells highlighted.", vbInformation, "Highlight"
    
End Sub

Function GetCombinedRange( _
    ByVal BuiltRange As Range, _
    ByVal AddRange As Range) _
As Range
    If BuiltRange Is Nothing Then
        Set GetCombinedRange = AddRange
    Else
        Set GetCombinedRange = Union(BuiltRange, AddRange)
    End If
End Function

相关内容