将前缀 vba 函数限制为动态范围

Posted 2023-02-22

【中文标题】将前缀 vba 函数限制为动态范围

【英文标题】：Limit the prefix vba function to dynamic range

【发布时间】：2021-07-02 20:07:52

【问题描述】：

enter link description here我只想将 vba 代码以下限制为动态范围内的 A 列。现在，如果我输入超出范围的内容，它会显示错误并破坏 Workbook_SheetChange 中的其他功能。 我附上我的文件以方便参考。 请帮忙 ！帮助

    'Formate Column A
If Target.Column = 1 Then
    Dim s As String
    Dim arr As Variant

    s = Target.Value
    If s = "" Then
      Target.NumberFormat = "General"
    Else
      With CreateObject("vbscript.regexp")
        .Pattern = "[^0-9]"
        .Global = True
        .IgnoreCase = True
        arr = Split(Application.Trim(.Replace(s, " ")), " ")
      End With
      Target.Value = arr
      Target.Value = Target.Value * 1
      Target.NumberFormat = """REQ0000000""General"
    End If

【问题讨论】：

如果（至少）你错过了一个结局。包括完整的代码，它会更容易帮助你

这是完整的代码。您可以使用提供的链接下载我的文件。如果活动单元格不是表格的连续行，我需要帮助修改代码以允许我像往常一样输入任何数字或字母值。

【参考方案1】：

    'Excel file link : https://drive.google.com/file/d/13w-AbgY83g02qHGqBrHr_6N26UkNpWKr/view?usp=sharing


Private Sub Workbook_BeforeClose(Cancel As Boolean)
        Call Module1.DeleteCheck
End Sub

Private Sub Workbook_Open()
        Call Module1.CreateCheck
        'Application.MoveAfterReturnDirection = xlToRight
        'Application.MoveAfterReturn = True
            

End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
    
  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select
 
      
  If Target.Column > 4 Or Target.CountLarge > 1 Then Exit Sub
  If Target.Row = 1 Then Exit Sub

 
  Application.EnableEvents = False
 
  If InStr(1, Cells(Target.Row, "A"), "REQ") <> "" And Cells(Target.Row, "B") <> "" Then
 
        Cells(Target.Row, "C") = ActiveSheet.Name
        Cells(Target.Row, "C").Font.Name = "Times New Roman"
        Cells(Target.Row, "C").Font.Size = 12
        Cells(Target.Row, "C").HorizontalAlignment = xlRight
        Cells(Target.Row, "D").ShrinkToFit = True
        Cells(Target.Row, "A").Font.Name = "Times New Roman"
        Cells(Target.Row, "A").Font.Size = 12
        Cells(Target.Row, "A").HorizontalAlignment = xlLeft
        Cells(Target.Row, "B").Font.Name = "Times New Roman"
        Cells(Target.Row, "B").Font.Size = 12
        Cells(Target.Row, "B").HorizontalAlignment = xlLeft
      
   End If
 
 
'Formate Column A
If Target.Column = 1 Then
    Dim s As String
    Dim arr As Variant

    s = Target.Value
    If s = "" Then
      Target.NumberFormat = "General"
    Else
      With CreateObject("vbscript.regexp")
        .Pattern = "[^0-9]"
        .Global = True
        .IgnoreCase = True
        arr = Split(Application.Trim(.Replace(s, " ")), " ")
      End With
      Target.Value = arr
      Target.Value = Target.Value * 1
      Target.NumberFormat = """REQ0000000""General"
    End If
  End If
 
 
  'Set Cell Movement within The Range
  'https://www.mrexcel.com/board/threads/set-movement-of-cells-in-dynamic-range-only.1172539/
   If Target.CountLarge > 1 Then Exit Sub
 
  
    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    If rng.Rows.Count > 1 Then
        Set rng = Intersect(Target, rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count))
    Else
        Set rng = Nothing
    End If
    If Not rng Is Nothing Then
        If Target.Column = 2 And Not (IsEmpty(Target)) Then
            Target.Offset(, 2).Select
        Else
            Target.Offset(, 1).Select`enter code here`
        End If
    End If
 
  Application.EnableEvents = True

End Sub


Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select

  If Target.Column <> 5 Or Application.CountA(Cells(Target.Row, 1).Resize(, 2)) < 2 Then Exit Sub
  Cancel = True
  Call Module3.SelectOLE3

End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select

  If g_blnWbkShtSelChange Then Exit Sub
  If Selection.Count = 1 Then
    If Not Intersect(Target, Range("C1")) Is Nothing Then
      g_blnWbkShtSelChange = True
      Call Module1.CheckSheet
    End If
  End If

End Sub

【讨论】：

@Tim，非常感谢