Excel VBA：基于ActiveCell地址的动态命名范围

如何解决Excel VBA：基于ActiveCell地址的动态命名范围

我正在尝试创建一个依赖于当前function index(array,arrayCost) { var maximum = Math.max(...array); var arrayIndex = []; for (var i = 0; i < array.length; i++) { if (array[i] == maximum) { arrayIndex.push(i); } } var resultIndex = arrayIndex[0]; var minimumCost = arrayCost[arrayIndex[0]]; //0.22 for (var i = 0; i < arrayIndex.length; i++) { if (arrayCost[arrayIndex[i]] <= minimumCost) { //0.25>=0.22 minimumCost = arrayCost[arrayIndex[i]]; resultIndex = arrayIndex[i]; } } return resultIndex; }的动态命名范围。数据集有两个笔划（扩展/缩进），每个笔划都有唯一的数据采样率，因此每个笔划的高度都会波动，并重置为1表示新笔划的开始。数据集的最后一列在每个行的末尾都有一个标记，指示行进的方向（请参见图片）。

该想法是将代码包装在“旋转按钮”（ActiveX控件）中，并允许用户向上或向下滚动数据集，仅绘制与该循环相关的数据。

我已经能够提取ActiveCell并将其存储在工作表上的单元格中，但是由于它是字符串，因此无法用作ActiveCell.Address中的引用。

Offset

或者，我提取当前的ws1.Range("AI1").Value = ActiveCell.Address（数据从第8行开始）以确定'Offset'的高度（不必担心列，它们是恒定的）

ActiveCell.Row

虽然这对第一组有效，但命名范围会扩大到包括下一个笔划和上一个笔划。这需要减去...

在另一种方法中，我使用录制的宏来模拟突出显示所用行之间的空白行。这确实提供了正确的计数，但是我不确定如何利用这一点...

ws1.Range("AI2").Value = ActiveCell.Row - 7

简而言之，我想计算Range(Selection,Selection.End(xlDown)).Select列中模拟T的{{1}}列中文本之间的空白单元格的数量，并创建一个以ctrldwn开头的命名范围点和文本之间的单元格数。

任何其他方法或建议都将感激不尽。

解决方法

坦率地说，我不太擅长理解你的照片。因此，在另一种方法上，我试图找到一种方法来利用您已经找到的解决方案，但未能找到可以肯定地加以利用的目的。

基本上，不会在工作表上存储不应保存的任何内容。任何数量的任何类型的变量都可以存储在内存中。关闭Excel或程序结束时，它将丢失。

Dim aCell As Range
Set aCell = Activecell

此代码将创建一个Range数据类型的变量，然后将其分配给ActiveCell对象，即使ActiveCell发生更改，该对象也将保持不变。您可以使用aCell的任何方式使用ActiveCell，例如

Debug.Print aCell.Address,aCell.Row
Set MyRange = Range(aCell,aCell.Offset(17))

请注意，如果有地址，则始终可以创建范围对象。 Set MyCell = ActiveSheet.Range("A3")创建一个这样的对象，aCell.Value = MyCell.Address撤消该过程。使用Set字来分配对象，字符串或数字不是必需的。

Selection是一个范围对象。因此，它具有范围的所有属性。

Dim sRange As Range
Set sRange = Selection
Debug.Print sRange.Address(0,0)
Set sRange = sRange.Resize(15)
Debug.Print sRange.Address,sRange.Worksheet.Name

我希望这会让您向上迈进一步。

按条件滚动

如有必要，调整工作表模块中的常数。
我使用两个命令按钮成功地测试了代码，但是我无法使它与旋转按钮的SpinUp和SpinDown事件一起正常工作（通常它将两次运行该过程，例如点击两次）。
我认为这与重点有关。同时，一个好主意是将命令按钮中的TakeFocusOnClick设置为False
Select Case语句应易于说明。

If语句

当Up被“使用”时，则在ActiveCell所在行和标准列上方的一行的交点处，它检查该值是否等于标准。如果是这样，则从上面的单元格开始搜索，尝试查找条件。如果找到，滚动到找到的单元格下方的一行，并激活其中ActiveCell的最初保存的列中的单元格。如果找不到条件，则滚动到由第六行（标题位于第五行，冻结五行）和ActiveCell的初始保存列定义的单元格。
当Down被“使用”时，则在ActiveCell所在行和标准列下方的一行的交点处，它检查该值是否等于标准。如果是这样，请从下面的单元格开始向下搜索，以查找条件。如果找到，滚动到找到的单元格下方的一行，并激活其中ActiveCell的最初保存的列中的单元格。如果找不到条件，它将尝试从下一行到该列底部的单元格中搜索条件。如果找到，则滚动到找到的单元格下方的一行，并激活其中ActiveCell最初保存的列中的单元格。否则退出该过程。

流程

命令按钮正在“调用”过程DirUp或DirDown，它们正在调用changeDirection过程，必要时将调用defineFoundCell过程。

标准模块，例如Module1

Option Explicit

Sub changeDirection(ByVal Criteria As String,_
                    Optional ByVal ignoreCase As Boolean = False,_
                    Optional ByVal ColumnIndex As Variant = 1,_
                    Optional ByVal FirstRow As Long = 1,_
                    Optional ByVal goUp As Boolean = False,_
                    Optional Sheet As Worksheet = Nothing)

    ' Initialize error handling.
    Const ProcName = "changeDirections"
    On Error GoTo clearError ' Turn on error trapping.

    If Sheet Is Nothing Then
        Set Sheet = ActiveSheet
    End If
    
    Dim cel As Range
    Set cel = Sheet.Cells(ActiveCell.Row,ColumnIndex)
    
    Dim ActiveColumnNumber As Long
    ActiveColumnNumber = ActiveCell.Column
    
    Dim rng As Range
    Dim ScrollToRow As Long
    
    If goUp Then
        
        Select Case cel.Row
            Case Is < FirstRow ' 'ActiveCell' is above 'FirstRow'.
                GoTo ProcExit
            Case Is = FirstRow ' 'Activecell' is in 'FirstRow'.
                GoTo ProcExit
            Case Else ' 'ActiveCell' is below 'FirstRow'. Continue...
        End Select
        
        If cel.Offset(-1).Value = Criteria Then
            defineFoundCell rng,cel.Offset(-2),Criteria,ignoreCase,_
                            False,FirstRow
        Else ' cel.Offset(-1).Value <> Criteria
            defineFoundCell rng,cel.Offset(-1),FirstRow
        End If
        
        If rng Is Nothing Then
            ScrollToRow = FirstRow
        Else
            ScrollToRow = rng.Row + 1
        End If
    
    Else ' (goDown)
        
        Select Case cel.Row
            Case Is < FirstRow ' 'ActiveCell' is above 'FirstRow'.
                ScrollToRow = FirstRow
                GoTo selectCellRange
            Case Is = FirstRow ' 'Activecell' is in 'FirstRow'. Continue...
            Case Else ' 'ActiveCell' is below 'FirstRow'. Continue...
        End Select
        
        If cel.Offset(1).Value = Criteria Then
            ScrollToRow = cel.Row + 2
        Else
            defineFoundCell rng,cel.Offset(1),_
                            True,FirstRow
            If rng Is Nothing Then
                GoTo ProcExit
            Else
                ScrollToRow = rng.Row + 1
            End If
        End If
    End If
    
selectCellRange:
    Sheet.Cells(ScrollToRow,ActiveColumnNumber).Activate
    ActiveWindow.ScrollRow = ScrollToRow

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Sub

Sub defineFoundCell(ByRef FindCellRange As Range,_
                    InitialCellRange As Range,_
                    ByVal Criteria As String,_
                    Optional ByVal getAfterInitialCell As Boolean = False,_
                    Optional ByVal ColumnIndex As Variant = 1)

    ' Initialize error handling.
    Const ProcName = "defineFoundCell"
    On Error GoTo clearError ' Turn on error trapping.
    
    Set FindCellRange = Nothing
    
    Dim ws As Worksheet: Set ws = InitialCellRange.Worksheet
    Dim FirstCell As Range
    Dim LastCell As Range
    If getAfterInitialCell Then
        Set FirstCell = InitialCellRange
        Set LastCell = ws.Cells(ws.Rows.Count,ColumnIndex)
        Set FindCellRange = ws.Range(FirstCell,LastCell) _
                              .Find(What:=Criteria,_
                                    After:=LastCell,_
                                    LookIn:=xlValues,_
                                    LookAt:=xlWhole,_
                                    MatchCase:=Not ignoreCase)
    Else ' getAfterInitialCell = False
        Set FirstCell = ws.Cells(FirstRow,ColumnIndex)
        Set LastCell = InitialCellRange
        Set FindCellRange = ws.Range(FirstCell,_
                                    SearchDirection:=xlPrevious,_
                                    MatchCase:=Not ignoreCase)
    End If

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Sub

工作表模块，例如Sheet1

Option Explicit

Private Const Criteria As String = "Extend"
Private Const CriteriaColumnID As Variant = "T" ' or 20
Private Const FirstRow As Long = 6

Sub DirUp()
    changeDirection Criteria,CriteriaColumnID,FirstRow,True,Me
End Sub

Sub DirDown()
    changeDirection Criteria,Me
End Sub

Private Sub CommandButton1_Click()
    DirUp
End Sub
Private Sub CommandButton2_Click()
    DirDown
End Sub

Private Sub SpinButton1_SpinUp()
    DirUp
End Sub
Private Sub SpinButton1_SpinDown()
    DirDown
End Sub

假设工作表中有一个SpinButton1，我创建了以下代码：

Private Sub SubSpin()
    
    'Declaring variables.
    Dim RngTop As Range
    Dim IntCounter01 As Integer
    Dim RngBottom As Range
    Dim StrName As String
    
    'Setting variable.
    StrName = "Section"
    
    'Resetting the SpinButton1 maximum value.
    SpinButton1.Max = Cells.Rows.Count
    
    'Checkpoint.
RestartLoop1:
    
    'Setting variables.
    Set RngTop = Range("T8")
    Set RngBottom = RngTop.End(xlDown)
    
    'Using a Do-Loop cycle to cover the entire list.
    Do Until IntCounter01 >= SpinButton1.Value
        
        'Checking if the code is about to pass the last row of the sheet.
        If RngTop.End(xlDown).Row = Cells.Rows.Count Then
                
                'Setting the maximum value of SpinButton1.
                SpinButton1.Max = SpinButton1.Value - 1
                
                'Quitting the loop.
                GoTo ExitLoop1
                
        End If
        
        'Setting variables.
        Set RngTop = RngTop.End(xlDown).Offset(1,0)
        Set RngBottom = RngTop.End(xlDown)
        IntCounter01 = IntCounter01 + 1
    
    Loop
    
    'Checkpoint.
ExitLoop1:
    
    'Naming the found range.
    ActiveWorkbook.Names.Add Name:=StrName,RefersToR1C1:="=Foglio1!R" & RngTop.Row & "C20:R" & RngBottom.Row & "C20"
    
    'Checking if the range is empty.
    If Excel.WorksheetFunction.CountBlank(Range(StrName)) = Range(StrName).Cells.Count Then
            'Setting variables to select the previous range.
            IntCounter01 = 0
            SpinButton1.Value = SpinButton1.Value - 1
            'Restarting the loop.
            GoTo RestartLoop1
    End If
    
    'Setting variables.
    Range("AI1").Value = SpinButton1.Value
    Range("AI2").Value = Range(StrName).Address
    
End Sub

Private Sub SpinButton1_SpinDown()
    Call SubSpin
End Sub
Private Sub SpinButton1_SpinUp()
    Call SubSpin
End Sub

它通过微调按钮创建一个指向“选定”部分的名称。它还在单元格AI1中打印SpinButton1的当前值，而在单元格AI2中则打印给定范围。该代码可防止选择空白部分和防止表中最后一个单元格超调。旋转按钮的最小值为0。我建议将其SmallChange属性设置为-1，以使用户更直观。

Excel VBA：基于ActiveCell地址的动态命名范围

如何解决Excel VBA：基于ActiveCell地址的动态命名范围

解决方法

按条件滚动

相关推荐