根据excel中单元格的值获取整行

Question

我试图根据任意单元格的值，获取从E到BH的特定范围内的整行数据。例如，如果单元格P，3上的值为“红色”，则我希望选择从E3到BH，3的整个范围。

此外，如果F9中的单元格上有值“黄色”，我希望选择从E9到BH9的整行

到目前为止，我一直在尝试从字符串“my text”中获取行，但它不起作用。我计划以与类似的方式获取行和列，以便根据文本获取从e（行）到bh（行）的行

Dim rng1 As Range
Set rng1 = Sheets("Table").UsedRange.Find("my text", xlValues, xlWhole)
Debug.Print "row is: " & rng1

Answer 1

迟到了，试图展示另一种方法，演示2019版的动态可能性，以及巧妙地使用范围函数：

Sub ExampleCall()
    '[0] define search item
    Const SearchItem As String = "My text"
    Dim rng As Range: Set rng = Sheet1.UsedRange                   ' Project's sheet Code(Name)
    '[1] evaluate condition
    Dim condition$: condition = "=IF(" & rng.Address & "=""" & SearchItem & """,ROW(" & rng.Address & "),"""")"
    Dim chk: chk = Evaluate(condition)
    '[2] get findings
    Dim rng1 As Range: Set rng1 = Range("E" & rng.Rows.Count + 1)  ' set dummy range (avoiding later checks for Is Nothing)
    Dim i As Long
    For i = 1 To UBound(chk)
        If Not IsError(Application.Average(Application.Index(chk, i, 0))) Then
            Set rng1 = Union(rng1, Intersect(Rows(i), Range("E:BH")))
            '' ... or do something with data field row Application.Index(chk, i, 0)
            '  ...
        End If
    Next i
    '[3] select rows with findings (after removing dummy from union range)
    If rng1.Areas.Count > 1 Then rng1.Areas(1).Delete ' delete dummy
    rng1.Select

End Sub

Answer 2

>

注意关键部分：

Const CopyColsAddress As String = "E:BH"
Set ccrg = ws.Columns(CopyColsAddress)
ccrg.Rows(i) 

代码

Option Explicit

Sub selectRowRanges()
    
    ' Constants
    Const wsName As String = "Table"
    Const FirstRow As Long = 2
    Const CopyColsAddress As String = "E:BH"
    Const CritColsList As String = "F,P"
    Const CriteriaList As String = "Yellow,Red"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Worksheet
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    ' Last Row
    Dim cel As Range
    Set cel = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If cel Is Nothing Then Exit Sub
    Dim LastRow As Long: LastRow = cel.Row
    If LastRow < FirstRow Then Exit Sub
    
    ' Copy-Columns Range
    Dim ccrg As Range: Set ccrg = ws.Columns(CopyColsAddress)
    
    ' Criteria
    Dim CritCols() As String: CritCols = Split(CritColsList, ",")
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    Dim cUpper As Long: cUpper = UBound(CritCols)
    
    ' Additional Variables
    Dim trg As Range ' Total Range
    Dim i As Long ' Range Row Counter
    Dim n As Long ' Criteria Counter
    
    ' Loop and combine matched row ranges in Total Range.
    For i = FirstRow To LastRow
        For n = 0 To cUpper
            If ws.Cells(i, CritCols(n)).Value = Criteria(n) Then
                If trg Is Nothing Then
                    Set trg = ccrg.Rows(i)
                Else
                    Set trg = Union(trg, ccrg.Rows(i))
                End If
                Exit For
            End If
        Next n
    Next i
    
    ' Select (Copy, Delete)
    If Not trg Is Nothing Then
        ' Often we do something like:
        'trg.Copy Sheet2.Range("A2")
        ws.Activate
        trg.Select
    End If
    
End Sub

Answer 3

可能使用Intersect和ENTIROW。请注意，您还应该使用“如果不存在，则rng1为Nothing”测试查找是否成功。

Set rng1 = Sheets("Table").UsedRange.Find(What:="my text", LookIn:=xlValues, LookAt:=xlWhole)

If Not rng1 Is Nothing Then
    Dim theNewRange As Range
    Set theNewRange = Intersect(rng1.EntireRow, Range("E:BH"))
End If

使用rng1的较短备选方案。行：

If Not rng1 Is Nothing Then
    Dim theNewRange As Range
    Set theNewRange = Range("E:BH").Rows(rng1.Row)
End If