Combine Two Worksheet_Change

Maverick_NL

New Member
Joined
Sep 7, 2022
Messages
7
Office Version
  1. 365
Platform
  1. Windows
HI I would like to combine two VBA codes but 1 works the other one does not :( I need the first code to monitor the two columns in the last code.
Hope someone can help
VBA Code:
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    x = xDic.Keys
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        Set xDCell = Cells(xCell.Row, 7)
        xDCell.Value = ""
        xDCell.Value = xDic.Items(I)
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim I, J As Long
    Dim xRgArea As Range
    On Error GoTo Label1
    If Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    Set xDependRg = Target.Dependents
    If xDependRg Is Nothing Then GoTo Label1
    If Not xDependRg Is Nothing Then
        Set xDependRg = Intersect(xDependRg, Range("C:C"))
    End If
Label1:
    Set xRg = Intersect(Target, Range("C:C"))
    If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = Union(xRg, xDependRg)
    ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = xDependRg
    ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
        Set xChangeRg = xRg
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    xDic.RemoveAll
    For I = 1 To xChangeRg.Areas.Count
        Set xRgArea = xChangeRg.Areas(I)
        For J = 1 To xRgArea.Count
            xDic.Add xRgArea(J).Address, xRgArea(J).Formula
        Next
    Next
    Set xChangeRg = Nothing
    Set xRg = Nothing
    Set xDependRg = Nothing
    Application.EnableEvents = True
End Sub

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 2 Then Exit Sub
    If (Not Intersect(Target, Range("C:C")) Is Nothing) Then
        With Target(1, 10)
        .Value = Date & " " & Time
        .EntireColumn.AutoFit
        End With
    End If
    If (Not Intersect(Target, Range("D:D")) Is Nothing) Then
        With Target(1, 10)
        .Value = Date & " " & Time
        .EntireColumn.AutoFit
        End With
    End If
End Sub
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Assuming that the code in each individual block is correct, then try this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

'   First block of code
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    x = xDic.Keys
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        Set xDCell = Cells(xCell.Row, 7)
        xDCell.Value = ""
        xDCell.Value = xDic.Items(I)
    Next
    
'   Second block of code
    If Target.Cells.Count <= 2 Then
        If (Not Intersect(Target, Range("C:C")) Is Nothing) Then
            With Target(1, 10)
            .Value = Date & " " & Time
            .EntireColumn.AutoFit
            End With
        End If
        If (Not Intersect(Target, Range("D:D")) Is Nothing) Then
            With Target(1, 10)
            .Value = Date & " " & Time
            .EntireColumn.AutoFit
            End With
        End If
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Hi Joe,
Thanks for your reply, it worked for row 9 😃 but not for the other ones. I've posted the sheet I'm working on with the code I'm trying to adapt.
The idea is to have a date filled in L & M when C&D are changed. When a second change is made the previous date in L should be remembered in Z. Haven't figured out how to M remembered in AA
There is still something not right because when I change C once more the date in L is updated but the change is not remembered in Z. Hope you can help!
VBA Knutselen Retain Value.xlsm
ABCDEFGHIJKLMZAA
1Project PlaceStatus
2Date StartOpenHoldDate completedDate StoppedOpenHoldCompletedStopppedDate openDate Hold
3Productivity & Sustainability10-1-2022xx24-2-202224724745#N/A14-9-2022 13:50:5114-9-2022 14:02:58
4Research & Scientific17-1-2022xx24-1-2022240240#N/A24014-9-2022 13:53:3914-9-2022 13:51:56
5Technology Platform7-2-2022xx219219#N/A#N/A14-9-2022 13:53:3814-9-2022 14:02:59
6Technology Platform14-2-2022xx212212#N/A#N/A14-9-2022 13:53:3714-9-2022 13:51:04
7New Product Development28-2-2022xx198198#N/A#N/A14-9-2022 13:53:3714-9-2022 13:51:05
8New Product Development4-3-2022xx194194#N/A#N/A14-9-2022 13:53:3714-9-2022 13:51:48
9Research & Scientific18-4-2023xx-216-216#N/A#N/A14-9-2022 14:03:1514-9-2022 13:51:02s
10Productivity & Sustainability15-5-2022xx122122#N/A#N/A14-9-2022 14:03:1514-9-2022 13:51:18
Sheet1
Cell Formulas
RangeFormula
G3:G10G3=IF(C3="X",TODAY()-B3,NA())
H3:H10H3=IF(D3="X",TODAY()-B3,NA())
I3I3=IF(ISBLANK(E3),NA(),E3-B3)
J3:J10J3=IF(ISBLANK(F3),NA(),TODAY()-B3)
I4:I10I4=IF(ISBLANK(E4),NA(),TODAY()-B4)
B4,B6B4=B3+7
B5B5=B4+21
B7B7=B6+14
Cells with Conditional Formatting
CellConditionCell FormatStop If True
G1:J1,B2:J2,A1:B1,A3:J10Cellcontains an errortextNO

VBA Code:
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    x = xDic.Keys
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        Set xDCell = Cells(xCell.Row, 26)
        xDCell.Value = ""
        xDCell.Value = xDic.Items(I)
    Next
    If Target.Cells.Count <= 2 Then
        If (Not Intersect(Target, Range("C:C")) Is Nothing) Then
            With Target(1, 10)
            .Value = Date & " " & Time
            .EntireColumn.AutoFit
            End With
        End If
        If (Not Intersect(Target, Range("D:D")) Is Nothing) Then
            With Target(1, 10)
            .Value = Date & " " & Time
            .EntireColumn.AutoFit
            End With
        End If
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim I, J As Long
    Dim xRgArea As Range
    On Error GoTo Label1
    If Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    Set xDependRg = Target.Dependents
    If xDependRg Is Nothing Then GoTo Label1
    If Not xDependRg Is Nothing Then
        Set xDependRg = Intersect(xDependRg, Range("L:L"))
    End If
Label1:
    Set xRg = Intersect(Target, Range("L:L"))
    If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = Union(xRg, xDependRg)
    ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = xDependRg
    ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
        Set xChangeRg = xRg
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    xDic.RemoveAll
    For I = 1 To xChangeRg.Areas.Count
        Set xRgArea = xChangeRg.Areas(I)
        For J = 1 To xRgArea.Count
            xDic.Add xRgArea(J).Address, xRgArea(J).Value
        Next
    Next
    Set xChangeRg = Nothing
    Set xRg = Nothing
    Set xDependRg = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Haven't figured out how to M remembered in AA
There is still something not right because when I change C once more the date in L is updated but the change is not remembered in Z.
If columns C or D is updated, you will then want to first check columns L and M for values.
If they have a value already, copy that values to the respective column Z or AA.
Then populate columns L or M.
 
Upvote 0
This sequence you suggest is written in the code? Or is it the way the code is built up?
I really suck at VBA 😏
 
Upvote 0
Try replacing this section:
VBA Code:
    If Target.Cells.Count <= 2 Then
        If (Not Intersect(Target, Range("C:C")) Is Nothing) Then
            With Target(1, 10)
                .Value = Date & " " & Time
                .EntireColumn.AutoFit
            End With
        End If
        If (Not Intersect(Target, Range("D:D")) Is Nothing) Then
            With Target(1, 10)
                .Value = Date & " " & Time
                .EntireColumn.AutoFit
            End With
        End If
    End If
with this:
VBA Code:
    If Target.Cells.Count = 1 Then
        If (Not Intersect(Target, Range("C:D")) Is Nothing) Then
'           Check to see if something already in exists in columns L or M
            If Target(1, 10) <> "" Then
'               Copy value to columns Z or AA
                Target(1, 24).Value = Target(1, 10).Value
            End If
'           Update columns L or M
            With Target(1, 10)
                .Value = Date & " " & Time
                .EntireColumn.AutoFit
            End With
        End If
    End If
 
Upvote 0
Solution
You are welcome.

If you notice, I was able to combine your two IF...THEN blocks to check both columns C and D at the same time, since the same behavior is happening to each of them.
Then I just added the check above it to see if anything was in L or M first, and if so, copy it over to Z or AA before updating L or M.
 
Upvote 0
The explanation in the code is very welcome. My VBA "skills" just got a bit better ;)
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,937
Members
448,534
Latest member
benefuexx

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