当指定的单元格范围为空时自动执行宏

Question

working/researching 使用我为工作场所任务开发的代码 sheet。当 F 列指示任务关闭时，第一部分调用 'movebasedonvalue' 宏。第二部分，我的目标是用宏 'NewUID' 重新分配一个新的 UID，作为一个独立的工作；我试图在 B 列指定范围内的单元格为空时立即调用它。

Private Sub Worksheet_Change(ByVal Target As Range)
    
        Dim Z As Long
        Dim xVal As String
        On Error Resume Next
        If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
        Application.EnableEvents = False
        For Z = 1 To Target.Count
            If Target(Z).Value > 0 Then
                Call movebasedonvalue 'Macro to select row and move row content to specified sheet
            End If
          Next
        Application.EnableEvents = True
        
    
End Sub
        
Private Sub FillBlanks(ByVal Target As Range)
        
            Dim rngBlanks As Range
            Dim ws As Worksheet
                
        Set rngBlanks = Range("B4:B8,B10:B14,B16:20") 'Specifying the range
        Set ws = ThisWorkbook.Worksheets("Burnout_Chart") 'Specifing Worksheet
        With ws
            If WorksheetFunction.CountBlank(rngBlank) > 0 Then 'wanting to identify blank cells in specified range
                For Each area In rngBlanks.SpecialCells(xlCellTypeBlanks).Areas 'Trying to
                        
                    Call NewUID 'Inputs new Unique ID into blank cell of Column B
                    
                Next
            End If
        End With
        
End Sub

这是我的 movebasedonvalue 代码：

Sub movebasedonvalue()
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
 A = Worksheets("Burnout_Chart").UsedRange.Rows.Count
 B = Worksheets("Completed").usedRange.Rows.Count
If B = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Burnout_Chart").Range("F4:F" & A)
On Error Resume Next
Application.ScreenUdating = False
For C = 1 To xRg.Count
    If CStr(xRg(C).Value) = "Closed" Then
    xRg(C).EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & B + 1)
    xRg(C).EntireRow.ClearContents
        If CStr(xRg(C).Value) = "Closed" Then

           C = C - 1
        End If
        B = B + 1
   End If
Next
Application.ScreenUpdating = True
End Sub

这是我的 NewUID 代码：

Sub NewUID(c As Range)
    Dim AR As Long
    Dim MaxID As Long
    Dim NewID As Long
    Dim Burnout As Worksheet
    Dim UID As Range
    
    
    Set Burnout = ThisWorkbook.Sheets("Burnout_Chart")
    Set UID = Range("B4:B8,B10:B14,B16:B20")
    
    MaxID = Application.WorksheetFunction.Max(UID)
    NewID = MaxID + 1
    AR = ActiveCell.Row
    

    ActiveCell.Value = NewID 'code to add id to cell c
End Sub

Answer 1

EDIT3：我最后的猜测

像这样的东西应该可以工作

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range, c As Range, rngUID As Range, nextID, nextRow As Long
    Dim wsComp As Worksheet
    
    On Error GoTo haveError
    
    Set rng = Intersect(Target, Me.Range("F:F"))
    If Not rng Is Nothing Then
        Set wsComp = ThisWorkbook.Worksheets("Completed")
        nextRow = NextEmptyRow(wsComp)
        Application.EnableEvents = False
        For Each c In rng.Cells
            If c.Value = "Closed" Then
                With c.EntireRow
                    .Copy wsComp.Cells(nextRow, "A")
                    .ClearContents
                    nextRow = nextRow + 1
                End With
            End If
        Next c
        Application.EnableEvents = True
    End If
    
    Set rngUID = Me.Range("B4:B8,B10:B14,B16:B20")
    Set rng = Intersect(Target, rngUID)
    If Not rng Is Nothing Then
        nextID = Application.Max(rngUID) + 1 'next ID
        
        Application.EnableEvents = False
        For Each c In rng.Cells
            If Len(c.Value) = 0 Then   'if cell is blank then assign an ID
                c.Value = nextID
                nextID = nextID + 1
            End If
        Next c
        Application.EnableEvents = True
    End If
    Exit Sub

haveError:
    Application.EnableEvents = True 'make sure events are re-enabled
End Sub

'given a worksheet, return the row number of the next empty row
Function NextEmptyRow(ws As Worksheet) As Long
    Dim f As Range
    Set f = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If f Is Nothing Then
        NextEmptyRow = 1
    Else
        NextEmptyRow = f.Row + 1
    End If
End Function

Answer 2

我解决了我的问题，有很多需要清理的地方，但这是我为我需要的代码而工作的代码：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Z As Long
    Dim xVal As String
    Dim KeyCells As Range 'redundant (Choose one or the other)
    Dim UID As Range 'redundant (Choose one or the other)
    Dim AR As Long 
    Dim MaxID As Long
    Dim NewID As Long
    Dim Burnout As Worksheet
    
    
    
    On Error Resume Next
    Set KeyCells = Range("B4:B8,B10:14,B16:B20") 'redundant (Choose one or the other)
    Set UID = Range("B4:B8,B10:B14,B16:B20") 'redundant (Choose one or the other)
    Set Burnout = ThisWorkbook.Sheets("Burnout_Chart")
    
    If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call movebasedonvalue
        End If
        If Not Application.Intersect(KeyCells, Range(Target.Address)) _
            Is Nothing Then
    MaxID = Application.WorksheetFunction.Max(UID)
    NewID = MaxID + 1
    AR = ActiveCell.Row
    Range("B" & AR).Select 'This is what I was missing
    

    ActiveCell.Value = NewID
        End If
      Next
    Application.EnableEvents = True
    

End Sub

当指定的单元格范围为空时自动执行宏

Automate macro when specified cell range is blank

excel

vba