Problems with a multiple "If not intersect" code

[MarcBeideler]

Hello,

I've a problem with my Code.

Everything worked well till I had to insert another condition, which is the last "If Not Intersect" in my code below.

Maybe anyone could help me to make it work

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim ws As Worksheet
   
    If Not Intersect(Target, Range("N5:Q405")) Is Nothing Then
        For Each c In Target
        If c.comment Is Nothing And c.Value <> "" Then
            Sheet1.Unprotect Password:="pbmi1327"
            With c.AddComment
                .Visible = False
                .Text Application.UserName & " - " & Date & " - " & Time & " - " & c.Value
            c.comment.Shape.TextFrame.AutoSize = True
            Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
            End With
       
        ElseIf c.comment Is Nothing And c.Value = "" Then
            Sheet1.Unprotect Password:="pbmi1327"
            With c.AddComment
                .Visible = False
                .Text Application.UserName & " - " & Date & " - " & Time & " - " & "Deleted"
            c.comment.Shape.TextFrame.AutoSize = True
            Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
            End With
           
        ElseIf Not c.comment Is Nothing And c.Value <> "" Or c.Value = "" Then
            Sheet1.Unprotect Password:="pbmi1327"
            c.comment.Text Application.UserName & " - " & Date & " - " & Time & " - " & c.Value & vbNewLine & c.comment.Text
            c.comment.Shape.TextFrame.AutoSize = True
            Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
            End If
           
        If Not Intersect(Target, Range("AC5")) Is Nothing Then
            Target.Copy
            Sheet1.Range("C5:C405" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
Next
End If
End Sub

 

[MarcBeideler]

This line of code:

Range("AC6:AC105").Copy Range("AD6")

copies the data in AC to column AD. This represent the data before any change is made in column F. When a change is made in column F, this part of the code compares the values in AC, which will have changed due to the change in column F, to the values in column AD. If the value in AC is different from the adjacent value in AD, the value of AC is copied to the bottom of column C.

For Each rng In Range("AC6:AC105")
                    If rng <> rng.Offset(, 1) Then
                        rng.Copy
                        Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        Exit For
                    End If
                Next rng

If it is not working that way, it is hard to see what the problem is without having access to your file. If you can't upload the file, perhaps you could de-sensitize the data and copy/paste a dozen or so rows here.

Maybe ther was a misunderstanding.
My table goes from row 5 to row 405.
In column C is entered which test/exam it is (Ex. Maths) in the ne next rows are the date and time an in column F is entered the number of students who were not present (Example: Class has 25 students and for the test 6 students were sick and stayed at home, so the number 6 is entered in F5) By entering a number higher than 0 in column AC is generated "extra exam Maths".
So this is done for every row, so that in row 6 its "English" and 3 students were absent (Cell f6=3)so in cell AC6 is generated "extra exam English".
I want that if the value in a cell in the column F changes to a value higher than 0 (which generates the column AC), the value of that row in column AC is copied to the first empty cell in C, so that the list will be continued and filled automatically with the extra exams.

I tried your code but only the first code is pasted below independent of the row I changed the value in F

Hope this way it would be more comprehensive.

 

[mumps]

I want that if the value in a cell in the column F changes to a value higher than 0 (which generates the column AC), the value of that row in column AC is copied to the first empty cell in C

As I mentioned before, the only way we can tell if a cell in AC has changed, is to compare that value to the previous value. That is why all the previous values in AC are copied to AD. The code then compares the values in the two columns and copies any that are different in AC to the bottom of column C. If it is not working the way I described, I need to see how your data is organized including which formulas you are using.

 

[mumps]

Try this version and see if it makes any difference.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim c As Range, rng As Range
    If Not Intersect(Target, Range("F:F,Q405,AC5")) Is Nothing Then
        Range("AC6:AC105").Copy Range("AD6")
        Select Case Target.Column
            Case 14 To 17
                For Each c In Target
                    If c.Comment Is Nothing And c.Value <> "" Then
                        Sheet1.Unprotect Password:="pbmi1327"
                        With c.AddComment
                            .Visible = False
                            .Text Application.UserName & " - " & Date & " - " & Time & " - " & c.Value
                            c.Comment.Shape.TextFrame.AutoSize = True
                            Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
                        End With
                    ElseIf c.Comment Is Nothing And c.Value = "" Then
                        Sheet1.Unprotect Password:="pbmi1327"
                        With c.AddComment
                            .Visible = False
                            .Text Application.UserName & " - " & Date & " - " & Time & " - " & "Deleted"
                            c.Comment.Shape.TextFrame.AutoSize = True
                            Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
                        End With
                    ElseIf Not c.Comment Is Nothing And c.Value <> "" Or c.Value = "" Then
                        Sheet1.Unprotect Password:="pbmi1327"
                        c.Comment.Text Application.UserName & " - " & Date & " - " & Time & " - " & c.Value & vbNewLine & c.Comment.Text
                        c.Comment.Shape.TextFrame.AutoSize = True
                        Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
                    End If
                Next c
            Case Is = 6
                Sheet1.Unprotect Password:="pbmi1327"
                For Each rng In Range("AC6:AC105")
                    If rng <> rng.Offset(, 1) Then
                        rng.Copy
                        Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        Exit For
                    End If
                Next rng
                Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
        End Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub