VBA code for changes in cell and delete cell value

[cooleomter]

The COde works if i only delete one by one.. But if i Highlight many cells and delete all at once.. it debugs
Need help please,... here is my code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nextRow As Long
Set historyWks = ActiveSheet

'Check if the changed cells are in the specified range
If Not Intersect(Target, Me.Range("C8:C3000")) Is Nothing Then
' to check cell if empty. or i delete
If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub 'Check if target cell is empty

With historyWks
nextRow = .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 1).Row
End With

With historyWks
With .Cells(nextRow, "G")
.Value = Date
.NumberFormat = "mm/dd/yyyy"
End With
With .Cells(nextRow, "F")
.Value = Time
.NumberFormat = "h:mm:ss AM/PM"
End With
With .Cells(nextRow, "D")
.Value = Range("F1").Value 'pACKING OPERATOR
End With
With .Cells(nextRow, "H")
.Value = Range("D2").Value ' MODEL
End With
With .Cells(nextRow, "I")
.Value = Range("F2").Value ' wEIGHING OPERATOR
End With

End With

End If


End Sub

 

[6StringJazzer]

I cannot test this without your file, but it handles changes to multiple cells.

When you paste code into your post it improves readability to add CODE tags by selecting the code and clicking the VBA button in the edit controls.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim nextRow As Long
   Set historyWks = ActiveSheet
   Dim Cell As Range
   
   For Each Cell In Target
   
      'Check if the changed cells are in the specified range
      If Not Intersect(Cell, Me.Range("C8:C3000")) Is Nothing Then
      
         ' to check cell if empty. or i delete
         If Cell.Value <> " " And Not IsEmpty(Cell) Then 'Check if Cell is empty
      
            With historyWks
               nextRow = .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 1).Row
            End With
            
            With historyWks
            
               With .Cells(nextRow, "G")
                  .Value = Date
                  .NumberFormat = "mm/dd/yyyy"
               End With
               With .Cells(nextRow, "F")
                  .Value = Time
                  .NumberFormat = "h:mm:ss AM/PM"
               End With
               With .Cells(nextRow, "D")
                  .Value = Range("F1").Value 'pACKING OPERATOR
               End With
               With .Cells(nextRow, "H")
                  .Value = Range("D2").Value ' MODEL
               End With
               With .Cells(nextRow, "I")
                  .Value = Range("F2").Value ' wEIGHING OPERATOR
               End With
            
            End With
            
         End If
      
      End If
   
   Next Cell


End Sub

 

[SunnyAlv]

try

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim nextRow As Long
Dim r As Range
Set historyWks = ActiveSheet


If Not Intersect(Target, Range("C8:C3000")) Is Nothing Then
    If Not Target.Cells.Value = "" Then
        With historyWks
            .Cells(Target.Row, "G").Value = Format(Date, "mm/dd/yyyy")
            .Cells(Target.Row, "F").Value = Format(Time, "h:mm:ss AM/PM")
            .Cells(Target.Row, "D").Value = .Range("F1").Value 'pACKING OPERATOR
            .Cells(Target.Row, "H").Value = .Range("D2").Value ' MODEL
            .Cells(Target.Row, "I").Value = .Range("F2").Value ' wEIGHING OPERATOR
        End With
            Else
        For Each r In Range("C8:C3000")
            If r.Value = "" Then
                With historyWks
                    .Cells(r.Row, "G").Value = ""
                    .Cells(r.Row, "F").Value = ""
                    .Cells(r.Row, "D").Value = ""
                    .Cells(r.Row, "H").Value = ""
                    .Cells(r.Row, "I").Value = ""
                End With
            End If
        Next r
    End If
End If


End Sub

 

[Fuji]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range
    Set rng = Intersect(Target, [C8:C3000])
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Each r In rng
        If Trim$(r) <> "" Then
            r(, 2) = [f1]
            With r(, 4).Resize(, 2)
                .Value = Array(Time, Date)
                .NumberFormat = Array("h:mm:ss AM/PM", "mm/dd/yyyy")
            End With
            r(, 6).Resize(, 2) = Array([D2], [F2])
        Else
            r.Range("b1,d1:g1").ClearContents
        End If
    Next
    Application.EnableEvents = True
End Sub

 

[cooleomter]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range
    Set rng = Intersect(Target, [C8:C3000])
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Each r In rng
        If Trim$(r) <> "" Then
            r(, 2) = [f1]
            With r(, 4).Resize(, 2)
                .Value = Array(Time, Date)
                .NumberFormat = Array("h:mm:ss AM/PM", "mm/dd/yyyy")
            End With
            r(, 6).Resize(, 2) = Array([D2], [F2])
        Else
            r.Range("b1,d1:g1").ClearContents
        End If
    Next
    Application.EnableEvents = True
End Sub

Tha

try

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim nextRow As Long
Dim r As Range
Set historyWks = ActiveSheet


If Not Intersect(Target, Range("C8:C3000")) Is Nothing Then
    If Not Target.Cells.Value = "" Then
        With historyWks
            .Cells(Target.Row, "G").Value = Format(Date, "mm/dd/yyyy")
            .Cells(Target.Row, "F").Value = Format(Time, "h:mm:ss AM/PM")
            .Cells(Target.Row, "D").Value = .Range("F1").Value 'pACKING OPERATOR
            .Cells(Target.Row, "H").Value = .Range("D2").Value ' MODEL
            .Cells(Target.Row, "I").Value = .Range("F2").Value ' wEIGHING OPERATOR
        End With
            Else
        For Each r In Range("C8:C3000")
            If r.Value = "" Then
                With historyWks
                    .Cells(r.Row, "G").Value = ""
                    .Cells(r.Row, "F").Value = ""
                    .Cells(r.Row, "D").Value = ""
                    .Cells(r.Row, "H").Value = ""
                    .Cells(r.Row, "I").Value = ""
                End With
            End If
        Next r
    End If
End If


End Sub

Thank you for correcting my code. THank you so much.

 

[cooleomter]

Try

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range
    Set rng = Intersect(Target, [C8:C3000])
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Each r In rng
        If Trim$(r) <> "" Then
            r(, 2) = [f1]
            With r(, 4).Resize(, 2)
                .Value = Array(Time, Date)
                .NumberFormat = Array("h:mm:ss AM/PM", "mm/dd/yyyy")
            End With
            r(, 6).Resize(, 2) = Array([D2], [F2])
        Else
            r.Range("b1,d1:g1").ClearContents
        End If
    Next
    Application.EnableEvents = True
End Sub

Thank you for correcting my code. THank you so much.

 

[cooleomter]

Thank you for correcting my code. THank you so much. and you make some additional features such as when i delete the input data on c column it also deletes the adjacent d,,f,g,h,and I column which makes me happy.. thank you

 

[cooleomter]

I cannot test this without your file, but it handles changes to multiple cells.

When you paste code into your post it improves readability to add CODE tags by selecting the code and clicking the VBA button in the edit controls.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim nextRow As Long
   Set historyWks = ActiveSheet
   Dim Cell As Range
  
   For Each Cell In Target
  
      'Check if the changed cells are in the specified range
      If Not Intersect(Cell, Me.Range("C8:C3000")) Is Nothing Then
     
         ' to check cell if empty. or i delete
         If Cell.Value <> " " And Not IsEmpty(Cell) Then 'Check if Cell is empty
     
            With historyWks
               nextRow = .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 1).Row
            End With
           
            With historyWks
           
               With .Cells(nextRow, "G")
                  .Value = Date
                  .NumberFormat = "mm/dd/yyyy"
               End With
               With .Cells(nextRow, "F")
                  .Value = Time
                  .NumberFormat = "h:mm:ss AM/PM"
               End With
               With .Cells(nextRow, "D")
                  .Value = Range("F1").Value 'pACKING OPERATOR
               End With
               With .Cells(nextRow, "H")
                  .Value = Range("D2").Value ' MODEL
               End With
               With .Cells(nextRow, "I")
                  .Value = Range("F2").Value ' wEIGHING OPERATOR
               End With
           
            End With
           
         End If
     
      End If
  
   Next Cell


End Sub

Thank you so much for correcting my code.
here my work..

test4.xlsm
	A	B	C	D	E	F	G	H	I	J
1			Category:		Packing Operator		Shipment Plan Qty:
2			Model		Weighing Operator		Finished Good Qty.:
3			Shipment Date:		Shipment Freight		Good Weight
4			Start Serial		End Serial		NG Weight
5			Minimum		Maximum		Lacking
6							Excess
7	Box No. BIG	Box No. SMALL	Weight	Packing Operator	Serial Number	Time	Date	Model	Weighing Operator	Remarks
8
9
10
11
12
13
14
15
MASTER COPY

Cell Formulas
Range	Formula
D5	D5	=IF((D2=""),"",INDEX(Validation!I2:I8,MATCH('MASTER COPY'!D2,Validation!F2:F8,0)))
F5	F5	=IF((D2=""),"",INDEX(Validation!J2:J8,MATCH('MASTER COPY'!D2,Validation!F2:F8,0)))
H1	H1	=IF(D4="","",(F4-D4+1))
H2	H2	=COUNT(C8:C100384)
H3	H3	=H2-H4
H4	H4	=((COUNTIFS(C8:C100000,"<"&D5)+(COUNTIFS(C8:C100000,">"&F5))))
H5	H5	=((COUNTIFS(C8:C10001,"<"&D5)))
H6	H6	=((COUNTIFS(L8:L10003,">"&O5)))
A8:A15	A8	=IFERROR(IFS($D$2="HDROP-14",INDEX(Serial!$E$2:$E$25426,MATCH('MASTER COPY'!E8,Serial!$A$2:$A$25426,0)),$D$2="IND-B",INDEX(Serial!$D$2:$D$25426,MATCH('MASTER COPY'!E8,Serial!$A$2:$A$25426,0)),OR($D$2="HDROP-FK1",$D$2="JD2100",$D$2="JD2000WH",$D$2="JD2000BK"),INDEX(Serial!$B$2:$B$25426,MATCH('MASTER COPY'!E8,Serial!$A$2:$A$25426,0)),$D$2="ZR-02",INDEX(Serial!$F$2:$F$25426,MATCH('MASTER COPY'!E8,Serial!$A$2:$A$25426,0))),"")
B8:B15	B8	=IFERROR(IFS(OR($D$2="HDROP-14",$D$2="ZR-02"),INDEX(Serial!$C$2:$C$25426,MATCH('MASTER COPY'!E8,Serial!$A$2:$A$25426,0))),"")
E7	E7	=IF(OR(D1="Option",D1="Harness"),"Item Count","Serial Number")
E8	E8	=IF(C8="","",D4)
E9:E15	E9	=IF(C9="","",E8+1)

Named Ranges
Name	Refers To	Cells
ACCList	=Validation!$F$6:$F$8	D5, F5
OPList	=Validation!$F$3:$F$5	D5, F5
SIBList	=Validation!$F$2	D5, F5

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C8:C1048576	Cell Value	<$D$5	text	NO
C8:C1048576	Cell Value	>$F$5	text	NO

Cells with Data Validation
Cell	Allow	Criteria
D1	List	=ManuList
D2	List	=INDIRECT(VLOOKUP($D$1,ManuLookUp,2,0) &"List")
D3	Any value
F1:F2	List	=OFFSET(Validation!$A$2:$A$999267,0,0,COUNTA(Validation!$A$2:$A$198)-0,1)
F3	List	=Validation!$C$10:$C$14

 

[cooleomter]

try

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim nextRow As Long
Dim r As Range
Set historyWks = ActiveSheet


If Not Intersect(Target, Range("C8:C3000")) Is Nothing Then
    If Not Target.Cells.Value = "" Then
        With historyWks
            .Cells(Target.Row, "G").Value = Format(Date, "mm/dd/yyyy")
            .Cells(Target.Row, "F").Value = Format(Time, "h:mm:ss AM/PM")
            .Cells(Target.Row, "D").Value = .Range("F1").Value 'pACKING OPERATOR
            .Cells(Target.Row, "H").Value = .Range("D2").Value ' MODEL
            .Cells(Target.Row, "I").Value = .Range("F2").Value ' wEIGHING OPERATOR
        End With
            Else
        For Each r In Range("C8:C3000")
            If r.Value = "" Then
                With historyWks
                    .Cells(r.Row, "G").Value = ""
                    .Cells(r.Row, "F").Value = ""
                    .Cells(r.Row, "D").Value = ""
                    .Cells(r.Row, "H").Value = ""
                    .Cells(r.Row, "I").Value = ""
                End With
            End If
        Next r
    End If
End If


End Sub

Thank you for your help all of you help me alot

 

[Fuji]

You are welcome.