Automate macro when specified cell range is blank-CodePudding

Been working/researching on this code I am developing for my workplace tasking sheet. First part calls for the 'movebasedonvalue' macro when column F indicates task is closed. Second part, what my goal is to reassign a new UID with the macro 'NewUID', which as a stand alone works; I am attempting to have it called as soon as a cell in specified range within column B is blank.

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

Here is my movebasedonvalue code:

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

Here is my NewUID code:

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

CodePudding user response：

I figured out my issue, there's a lot that needs to be cleaned up but here is the code I got working for what I need:

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

CodePudding user response：

EDIT3: my last guess

Something like this should work

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