Combine Two Worksheet_Change

Maverick_NL · Sep 14, 2022

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

Joe4 · Sep 14, 2022

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

Maverick_NL · Sep 14, 2022

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

A

B

C

D

E

F

G

H

I

J

K

L

M

Z

AA

1

Project Place

Status

2

Date Start

Open

Hold

Date completed

Date Stopped

Open

Hold

Completed

Stoppped

Date open

Date Hold

3

Productivity & Sustainability

10-1-2022

x

24-2-2022

247

45

#N/A

14-9-2022 13:50:51

14-9-2022 14:02:58

4

Research & Scientific

17-1-2022

x

24-1-2022

240

#N/A

240

14-9-2022 13:53:39

14-9-2022 13:51:56

5

Technology Platform

7-2-2022

x

219

#N/A

14-9-2022 13:53:38

14-9-2022 14:02:59

6

Technology Platform

14-2-2022

x

212

#N/A

14-9-2022 13:53:37

14-9-2022 13:51:04

7

New Product Development

28-2-2022

x

198

#N/A

14-9-2022 13:53:37

14-9-2022 13:51:05

8

New Product Development

4-3-2022

x

194

#N/A

14-9-2022 13:53:37

14-9-2022 13:51:48

9

Research & Scientific

18-4-2023

x

-216

#N/A

14-9-2022 14:03:15

14-9-2022 13:51:02

s

10

Productivity & Sustainability

15-5-2022

x

122

#N/A

14-9-2022 14:03:15

14-9-2022 13:51:18

Sheet1

Cell Formulas
Range	Formula
G3:G10	G3	=IF(C3="X",TODAY()-B3,NA())
H3:H10	H3	=IF(D3="X",TODAY()-B3,NA())
I3	I3	=IF(ISBLANK(E3),NA(),E3-B3)
J3:J10	J3	=IF(ISBLANK(F3),NA(),TODAY()-B3)
I4:I10	I4	=IF(ISBLANK(E4),NA(),TODAY()-B4)
B4,B6	B4	=B3+7
B5	B5	=B4+21
B7	B7	=B6+14

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
G1:J1,B2:J2,A1:B1,A3:J10	Cell	contains an error	text	NO

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

Joe4 · Sep 14, 2022

Maverick_NL said:
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.

Maverick_NL · Sep 14, 2022

This sequence you suggest is written in the code? Or is it the way the code is built up?
I really suck at VBA

Joe4 · Sep 14, 2022

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

Maverick_NL · Sep 14, 2022

Thanks! That worked!

Joe4 · Sep 14, 2022

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.

Maverick_NL · Sep 14, 2022

The explanation in the code is very welcome. My VBA "skills" just got a bit better

Combine Two Worksheet_Change

Maverick_NL

New Member

Excel Facts

Joe4

MrExcel MVP, Junior Admin

Maverick_NL

New Member

Joe4

MrExcel MVP, Junior Admin

Maverick_NL

New Member

Joe4

MrExcel MVP, Junior Admin

Maverick_NL

New Member

Joe4

MrExcel MVP, Junior Admin

Maverick_NL

New Member

Similar threads

Forum statistics

Share this page

Combine Two Worksheet_Change

New Member

Excel Facts

MrExcel MVP, Junior Admin

New Member

MrExcel MVP, Junior Admin

New Member

MrExcel MVP, Junior Admin

New Member

MrExcel MVP, Junior Admin

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock