繁体   English   中英

使用VBA根据特定值识别范围

Using VBA to identify ranges based on specific values

提示:本站收集StackOverFlow近2千万问答,支持中英文搜索,鼠标放在语句上弹窗显示对应的参考中文或英文, 本站还提供   中文繁体   英文版本   中英对照 版本,有任何建议请联系yoyou2525@163.com。

这是我的第一篇文章,我是一个初学者。 请保持温柔。 请参阅此链接以获取我正在使用的工作表的参考。

我的计划是让B2包含一个下拉列表,该列表将用于选择性地将某些行组折叠为它们的标题。 我已经弄清楚如何用这个折叠一组:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    Set KeyCells = Range("B1")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
        Is Nothing Then

       If Range("B1") = "All" Then
            Rows("3:6").Select
            Selection.EntireRow.Hidden = False
            Range("B1").Select
       Else
            Rows("3:6").Select
            Selection.EntireRow.Hidden = True
            Range("B1").Select
       End If

    End If

End Sub

我所没有的是一种自动查找组的方法。 如果我使用Rows(“ 3:6”)之类的范围并且有人添加/删除行,则它将行不通。 (对?)

我需要的是一种通过查看标题中的信息来标识所需范围的方法。 参考示例为空白,但每个灰色行的“ A”列将是一个数字(100、101、150、380、420A,420B,420C,890)。 没有数字将出现两次,并且将按数字顺序出现。 灰色标题下白色单元格中的“ A”列将全部为空白。

是否有VBA代码可以找到唯一标头的位置,以便我可以使用它们的位置折叠特定组?

进行其他编辑以添加新的屏幕快照,以实现我的期望。 X,Y,Z人都有他们想要扩展或折叠的预定组。 如果我能弄清楚的话,我可能会添加“ all”和“ none”。 他们会提前给我的。 左边的数字永远不会改变。 这只是Person X是否希望组120扩展或折叠的问题。 https://imgur.com/c2lNujn

编辑以显示当前代码:

Public HeaderColor As Long


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Me.HeaderColor = RGB(217, 217, 217)

    'If A1 is true, group rows
    If Range("A1").Value Then
        'Use getRegion function on target
        Dim rng As Range
        Set rng = getRegion(Target)

        'If the returned range is nothing then end sub
        If rng Is Nothing Then Exit Sub

        'Select region
        Application.EnableEvents = False
            rng.Select
        Application.EnableEvents = True
    End If

    'If D1 is true, apply Y/N options for selection in C1
    If Range("D1").Value Then

    Dim rngX As Range, c As Range
    Set rngX = Worksheets("Options").Range("A1:N1").Find(Range("C1"), lookat:=xlPart)

    If Not rngX Is Nothing Then
        'MsgBox Chr(34) & Range("C1").Value & Chr(34) & " found at " & rngX.Address
    End If

'Check
'    Dim groupcounter As Long
'    For groupcounter = 1 To 80
'        If Worksheets("Options").Range(rngX.Column, groupcounter + 1) = "Y" Then
'            getNthRegion(ActiveSheet, groupcounter).Hidden = True
'        ElseIf Worksheets("Options").Range(rng.Column, groupcounter + 1) = "N" Then
'            getNthRegion(ActiveSheet, groupcounter).Hidden = False
'        End If
'    Next groupcounter
End If


End Sub
Sub customiseVisibility(ByVal query As String)
    Dim cell As Range
    Set cell = OptionsSheet.Range("1:1").Find(query)
    Dim offset As Long
    offset = 1
    While Not IsEmpty(cell.offset(offset))
        getNthRegion(MySheet, offset).Hidden = cell.offset(offset).Value = "N"
        offset = offset + 1
    Wend
End Sub

Private Function getRegion(cell As Range) As Range
    Dim formatted As Boolean
    Dim cell_start, cell_end As Range

    'If cell row is 1 then exit function
    If cell.Row <= 1 Then Exit Function

    'If cell row count > 1 then use first cell selected
    If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)

    'If selection is outside of used range, do nothing
    If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function

    'Special condition
    If cell.Interior.Color = Me.HeaderColor Then
        'Select row below
        Set cell = cell.offset(1)
    End If

    'Get start cell
    Set cell_start = cell
    While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_start = cell_start.offset(-1)
    Wend

    'Get end cell
    Set cell_end = cell
    While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_end = cell_end.offset(1)
    Wend

    'Get region
    Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function

Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
    Dim i, counter As Long
    For i = 1 To sheet.UsedRange.Rows.Count
       If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
          counter = counter + 1
       End If
       If counter = n Then
           Set getNthRegion = getRegion(sheet.Cells(i, 1))
           Exit Function
       End If
    Next
End Function
3 个回复

正如@BigBen建议的那样-使用FIND ,然后在标题之间进行分组-从“开始”向下一行,从“结束”向上一行。

Public Sub CreateOutline()

    Dim sFirstAdd As String
    Dim rFound As Range
    Dim rStart As Range
    Dim rEnd As Range

    With ThisWorkbook.Worksheets("Sheet1")

        .Cells.ClearOutline 'Remove any existing.

        With .Cells.EntireColumn
            Set rFound = .Find(What:="*", _
                               After:=.Cells(1, 1), _
                               LookIn:=xlValues, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext)

            If Not rFound Is Nothing Then
                sFirstAdd = rFound.Address
                Do
                    Set rStart = rFound
                    Set rFound = .FindNext(rFound)
                    Set rEnd = rFound

                    Range(rStart.Offset(1), rEnd.Offset(-1)).Rows.Group

                    'Include a marker to state where the end of the last section is.
                    'Otherwise the last section will go from cell A1 to just below last section header.
                    If rEnd = "End" Then sFirstAdd = rFound.Address

                Loop While rFound.Address <> sFirstAdd
            End If

        End With
    End With

End Sub

代替隐藏和Outline.ShowLevels隐藏行,可以使用Outline.ShowLevels方法折叠分组。

所以像这样:

  • 测试B1更改。
  • 在第一列中Find相应的标题。
  • 如果有匹配项,请测试下一行是否有分组( OutlineLevel > 1 )。
  • 如果是这样, ShowDetail = False该行的ShowDetail = False

请注意,不建议使用On Error Resume Next 但是,当指定的组已经折叠时, .ShowDetail = False引发错误。 当我进一步调查时,这是快速解决方案。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Me.Range("B1"), Target) Is Nothing Then
        With Me
            Dim rng As Range
            Set rng = .Columns(1).Find(.Range("B1").Value)

            If Not rng Is Nothing Then
                With rng.Offset(1).EntireRow
                    On Error Resume Next
                    If .OutlineLevel > 1 Then .ShowDetail = False
                End With
            End If
        End With
    End If
End Sub

您会滥用格式吗?

这是经过测试的代码:

Public  HeaderColor  as Long
Private OptionsSheet as Worksheet
Private DataSheet    as Worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
  Me.HeaderColor = RGB(217, 217, 217)
  set OptionsSheet = sheets("Options")
  set DataSheet = ActiveWorksheet

  if target.address = "$B$1" then
    customiseVisibility target.value
  end if
End Sub

Sub customiseVisibility(ByVal query As String)
  Dim cell As Range
  Set cell = OptionsSheet.Range("1:1").Find(query)
  Dim offset As Long
  offset = 1
  While Not IsEmpty(cell.offset(offset))
    getNthRegion(DataSheet, offset).Hidden = cell.offset(offset).Value = "N"
    offset = offset + 1
  Wend
End Sub
Private Function getRegion(cell As Range) As Range
    Dim formatted As Boolean
    Dim cell_start, cell_end As Range

    'If cell row is 1 then exit function
    If cell.Row <= 1 Then Exit Function

    'If cell row count > 1 then use first cell selected
    If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)

    'If selection is outside of used range, do nothing
    If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function

    'Special condition
    If cell.Interior.Color = Me.HeaderColor Then
        'Select row below
        Set cell = cell.offset(1)
    End If

    'Get start cell
    Set cell_start = cell
    While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_start = cell_start.offset(-1)
    Wend

    'Get end cell
    Set cell_end = cell
    While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_end = cell_end.offset(1)
    Wend

    'Get region
    Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function
Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
    Dim i, counter As Long
    For i = 1 To sheet.UsedRange.Rows.Count
       If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
          counter = counter + 1
       End If
       If counter = n Then
           Set getNthRegion = getRegion(sheet.Cells(i, 1))
           Exit Function
       End If
    Next
End Function

注意:

这个问题真的很具体。 下次尝试将您的问题分解为较小的部分,并一次处理一个问题(如果有的话)。 另外,我强烈建议您添加示例数据进行处理。 例如

| Number | All | PersonA | PersonB | ...
-----------------------------------------
|   1    |  N  |    Y    |    N    | ...
|   2    |  N  |    Y    |    N    | ...
|   3    |  N  |    Y    |    N    | ...
|   4    |  N  |    Y    |    Y    | ...
|   5    |  N  |    N    |    N    | ...
|   6    |  N  |    N    |    Y    | ...
|   7    |  N  |    N    |    N    | ...
|   8    |  N  |    N    |    Y    | ...
2 使用VBA识别特定范围内的第一个空列

我有以下Excel电子表格: 公式: 该电子表格显示了公司每月的表现。 每次达到新的月份时,我都希望将上个月的值复制到新的月份。 因此,我需要确定第一个空列。 我尝试从此处使用VBA解决方案: 现在的问题是,与这个问题相反,我有一个新的G列 ,它显示了总体性能。 ...

2019-07-19 06:24:57 2 53   excel/ vba
3 使用像元值作为范围VBA

我正在尝试从一个单元格中拾取一个范围(称为“ A5:L10”)。 换句话说,我的代码看起来类似于下面的代码: 其中summ_rng1 =“ A5:L10” 我在代码中对工作簿和工作表做了同样的事情,并且工作正常,但是当我尝试用变量summ_rng1替换范围引用时,它不起作用。 ...

4 使用 VBA 以特定方式动态添加范围

我想使用类似于发布的图像的 excel/vba 创建一个表格。 下面是我的代码。 我将第 1 部分定义为命名范围,然后将其复制并粘贴到底部,并在执行过程中清除用户输入。 我需要什么指导。 此代码将每个范围粘贴到底部。 我想像图像一样粘贴它,先从左到右,然后从上到下,每行 2 个。 ...

2021-11-19 17:39:50 1 33   excel/ vba
6 VBA 代码问题:在循环特定值的范围时使用偏移量

我已经编写了一个 VBA 代码来循环遍历特定值的范围,选择包含该值的单元格、紧邻其上方的单元格和紧邻其下方的单元格使用偏移量。 问题是代码选择了单元格值的第一个实例为 1111 和两个偏移量(选择了 1111、紧接其上方的单元格和紧接其下方的单元格),但不为其余的范围内的指定值及其各自(紧接其上方和 ...

8 VBA和SQL如何根据excel中的范围选择特定值?

我是 vba (excel) 和 oracle 数据库连接的新手。 我试图寻找一些信息,但我找不到任何适合我的信息。 我想编写一个查询,只返回包含特定值的行。 我的查询如下所示: SQLStr = SQLStr = "SELECT NGKHFHCD, NGKHFNAM, NGKHGNKA, NGK ...

9 添加范围和值VBA

第一个公式有效,但接下来的两个公式无效。 有人可以在添加这样的值时解释正确的语法吗? 例如,何时使用“&”号并正确放置引号。 预先感谢。 Range("F1").Formula = "=(" &amp; Range("I1").Value * 1000 &amp; ")/1000" R ...

10 使用VBA更新特定行上的列值

如何在第6列第一行中将值从xt更新为xtt。 基于以上数据,我正在从工作表中获取信息。 获取Row对象后,如何更新特定列中的Cell值? ...

2011-10-11 11:44:11 1 3192   excel/ vba
暂无
暂无

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2021 STACKOOM.COM