Question

我正在写一张excel工作表。

我有一个功能，可以在用户将某些内容输入单元格后自动对工作表进行排序。

所以问题是，如果他们输入的行被排序到另一个位置，用户会很快被激怒，并且他们被迫再次找到它。

有没有办法在vba / excel中引用相同的行，而不是行号？

当我尝试使用

更改用户的活动行时

ActiveWindow.ScrollRow = Target.Row

它只是以数字方式而不是逻辑方式选择一行。

我想要一个指向该行对象的指针，而不是指向该行索引的指针。

Function HaveNumbers(oRng As Range) As Boolean
     Dim bHaveNumbers As Boolean, I As Long
     bHaveNumbers = False
     For I = 1 To Len(oRng.Text)
         If IsNumeric(Mid(oRng.Text, I, 1)) Then
             bHaveNumbers = True
             Exit For
         End If
     Next
     HaveNumbers = bHaveNumbers
End Function

Function InRange(Range1 As Range, Range2 As Range) As Boolean
    ' returns True if Range1 is within Range2
    InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
End Function

'This should be used to signify which columns have multi-select drop down
Function IsMultiSelectDropDown(Range0 As Range) As Boolean
    IsMultiSelectDropDown = InRange(Range0, Range("G2:G99999")) Or InRange(Range0, Range("H2:H99999"))
End Function

Function IsNumberCell(Range0 As Range) As Boolean
    IsNumberCell = InRange(Range0, Range("M2:M99999"))
End Function

Function RangeIsEmpty(Range0 As Range) As Boolean
    For Each Cell In Range0.Cells
        If Not Cell.Value = "" Then
            RangeIsEmpty = False
            Exit Function
        End If
    Next

    RangeIsEmpty = True
End Function

Sub EnsureLength(ByRef Cell As Range)
    Dim Length As Integer
    Dim Text As String

    If InRange(Cell, Range("A2:A99999")) Then
        Length = 20
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    ElseIf InRange(Cell, Range("B2:B99999")) Then
        Length = 80
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    ElseIf InRange(Cell, Range("C2:C99999")) Then
        Length = 80
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    ElseIf InRange(Cell, Range("J2:J99999")) Then
        Length = 20
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    ElseIf InRange(Cell, Range("K2:K99999")) Then
        Length = 20
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    ElseIf InRange(Cell, Range("L2:L99999")) Then
        Length = 20
        Text = Cell.Value

        If Len(Cell.Text) > Length Then
            MsgBox ("This cell cannot exceed " + Str(Length) + " characters.")
            Cell.Value = Left(Text, Length)
        End If
    End If

End Sub

Sub EnsureNumber(Cell As Range)
    If IsNumberCell(Cell) And Not HaveNumbers(Cell) Then
      Cell.Value = "0"
    End If
End Sub

Sub AutoSort(Cell As Range)
    On Error Resume Next
    If InRange(Cell, Range("B2:B99999")) Then
        Range("B1").Sort Key1:=Range("B2"), _
        Order1:=xlDescending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
    End If
End Sub

Private Sub SingleEdit(ByVal Target As Range)
    Application.EnableEvents = False


    'Code by Sumit Bansal from https://trumpexcel.com
    ' To Select Multiple Items from a Drop Down List in Excel
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    On Error GoTo Exitsub

    If IsMultiSelectDropDown(Target) Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
      GoTo Exitsub
    Else: If Target.Value = "" Then GoTo Exitsub Else
      Application.EnableEvents = False
      Newvalue = Target.Value
      Application.Undo
      Oldvalue = Target.Value
        If Oldvalue = "" Then
          Target.Value = Newvalue
        Else
          If InStr(1, Oldvalue, Newvalue) = 0 Then
              Target.Value = Oldvalue & "-" & Newvalue
        Else:
          Target.Value = Oldvalue
        End If
      End If
    End If
End If


    Dim Row As Range
    Dim Cell As Range
    Dim I As Integer
    I = 0
    Set Row = Rows(Target.Row)
    For Each Cell In Row.Cells
        Call EnsureNumber(Cell)
        Call EnsureLength(Cell)

        I = I + 1

        If I > 26 Then
          Exit For
        End If
    Next

Exitsub:
Application.EnableEvents = True
    Application.EnableEvents = True
End Sub

Private Sub MultiEdit(ByVal Target As Range)
    Dim T As Range
    Dim LastRow As Integer
    LastRow = 0

    If Not RangeIsEmpty(Target) Then
        For Each T In Target
            If Not LastRow = T.Row Then
                Call SingleEdit(T)
                LastRow = T.Row
            End If
        Next
    End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
  Call MultiEdit(Target)
Else
  Call SingleEdit(Target)
End If

    Dim Row As Range
    Dim Cell As Range
    Dim I As Integer
    I = 0
    Set Row = Rows(Target.Row)
    For Each Cell In Row.Cells
        Call AutoSort(Cell)

        I = I + 1

        If I > 26 Then
          Exit For
        End If
    Next

    ActiveWindow.ScrollRow = Target.Row
End Sub

VBA参考排序后的同一行

0 个答案: