Problems with a multiple "If not intersect" code

M

MarcBeideler

New Member
Joined
Jan 26, 2021
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code: 
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
 
Last edited by a moderator:

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim c As Range
    Dim ws As Worksheet
    If Not Intersect(Target, Range("N5:Q405,AC5")) Is Nothing Then
        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 = 29
                Sheet1.Unprotect Password:="pbmi1327"
                Target.Copy
                Sheet1.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                Sheet1.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=False, Scenarios:=True, Password:="pbmi1327"
        End Select
    End If
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank you,
I'll try tomorrow.

What if I would continue with the cells AC6-AC105
All the AC cells will contain a formula and will change by entering data in the column F.

My idea was to have a VBA that runs if one of the cells in range AC5:AC105 changes and copy the value only of that cell that changed to the first empty cell in column C and everything by containing the VBA for inserting comments by change in the range N5:Q405

Thank you
 
Upvote 0
I'm sorry but I don't follow. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
mumps said:
I'm sorry but I don't follow. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Click to expand...
Upload is unfortunately not possible du to security settings at work.

Well it is a planning for tests.
in the column C (C5:C405) are the tests, and in the next columns are the date, time from, time to, the instructor etc.
in column F is entered the number of students that were not present, so that an extra test is has to be made.
With an if formula and concatenate in the same row will appear, after entering the number of students missing the test, in column AC the new name (example: Cell C6 was "French" and 3 students were absent, so by entering 3 in the cell F6 the cell AC6 will change to "extra test French") and this cell should be copied to the next free cell in column C.
Like this every day the list will be updated and no extra test will be forgotten in the list.

Hope this will help you to understand.
Sorry for my bad English, it's not my first language.
 
Upvote 0
The only way that would be possible is to use a helper column which stores the old values in column AC and then compares those values to the new values after the formulae have calculated. Is column AD unused?
 
Upvote 0
mumps said:
The only way that would be possible is to use a helper column which stores the old values in column AC and then compares those values to the new values after the formulae have calculated. Is column AD unused?
Click to expand...
Hello,

yes column AD is unused
 
Upvote 0
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = 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.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = 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.ScreenUpdating = True
End Sub
Click to expand...
Hello, thank you,

I tried but it don't work.
It copies the first row of AC in the whole column range AD and sets the first entry of AD down in column C. With my next entry in the next row it copies again the first entry
 
Upvote 0
This line of code:
VBA 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.
VBA Code: 
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Auto Date Stamp
Replies
3
Views
411
Joe4
Joe4
H
  • Question
Save and Close Excel after a 15min inactivity.
Replies
1
Views
62
Logit
Logit
F
  • Question
VBA - formatting/grouping with protected workbook
Replies
1
Views
491
ExcelToDAX
E
E
  • Solved
Macro to run anytime a ActiveX checkbox is used (no linked cells)
Replies
8
Views
374
John_w
J
K
  • Question
VBA with password-protected sheet
Replies
5
Views
312
Logit
Logit

Forum statistics

Threads
1,215,477
Messages
6,125,037
Members
449,205
Latest member
Eggy66

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top