VBA Code to copy data range from one sheet to another based on a changing value.

[uk_2022]

I need help with a VBA code that will enable me to copy data from one sheet to another sheet if the value in a column is "YES".

The value in column K has a formula which changes the value from NO to YES, based on manually entered data within column N or TRUE values in column O & P which are based on the values in other sheets.

I have tried uploading a mini-sheet but unfortunately it just keeps crashing the program.

Totally new to VBA codes.

 

[mumps]

A Worksheet_Change event can only be triggered by a manual entry in a cell. Column K is not entered manually but rather it is the result of a formula. A Worksheet_Calculate event is triggered when a formula is calculated so that might work. The problem is that you have many formulae in the sheet and the Worksheet_Calculate event would be triggered when any of the formulae is calculated, not just the formula in column K. I had a look at all the formulae in sheets Data, Sheet1 and Sheet4 on which the value in column K is dependent. It appears to me that the value in column K is originally dependent on whether or not the value in column A of Data exists in either Sheet1 or Sheet4, but the value in column A of Data is dependent on columns H and I of Data. If that is the case, then a Worksheet_Change event in Data that is triggered on the manual entry of the Surname in column I might work. Try this macro in the code module for sheet Data. Start entering data in columns C to I and after you have entered the surname in column I, press the TAB key or ENTER key.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 9 Then Exit Sub
    Application.ScreenUpdating = False
    If Target.Offset(, 2) = "YES" Then
        Sheets("EQUAL").Range("C9", Sheets("EQUAL").Range("I" & Rows.Count).End(xlUp)).ClearContents
        With Sheets("Data")
            .Range("A8").AutoFilter 11, "YES"
            .Range("C9", .Range("I" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy Sheets("EQUAL").Range("C9")
            .Range("A8").AutoFilter
        End With
    End If
    Application.ScreenUpdating = True
End Sub

If you also want the data to be copied to the EQUAL sheet when you select "YES" in column N, please let me know and I will make the necessary changes to the macro.

 

[uk_2022]

Hi

Thanks again for the reply.

Column C-G in each sheet will populate from the 'data' sheet if the name entered in H:I is found in the 'Data' sheet (VLOOKUP)

I want the VBA code to automatically copy the names that have YES in 'Data' sheet, column K into H:I in the 'EQUAL' sheet.

After the initial copy I need the code to only copy any new names when column K changes from NO to YES.

The code is currently adding names already in the list.

In essence I need names in H:I to copy to the 'EQUAL' sheet if

'DATA' Sheet, column K = YES

or

'DATA' sheet, column M = TRUE
'DATA' sheet, column N = YES

column K, M are both populated by a formula rather than manual change. column N is the only manual change.

column M is TRUE if column O or column P are TRUE.
column O is TRUE if 'sheet 1, column V is TRUE
column P is TRUE is 'sheet 4', column P is TRUE

if the code can only pick up manual changes, can it do so from different sheets?

If so, manual changes would be made in;

'sheet 1', column T
'sheet 4', column AD
'data', column N

it would need to copy H:I from 'sheet 1', 'sheet 4' or 'data' into the 'EQUAL' sheet.

TIA

 

[mumps]

How are the names entered in columns H and I of the Data sheet?

 

[uk_2022]

They are copied and pasted from a separate spreadsheet - does that mean they are manually added?

or does manually added actually mean each one is typed in individually?

 

[mumps]

Change the formula in K9 of Data to: =IF(OR(M9=TRUE,N9=TRUE),"YES","NO") and copy the formula down the column. In the EQUAL sheet, delete all the formulae in columns C to I.
Place this macro in the code module for sheet Data:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 14 Then Exit Sub
    Application.ScreenUpdating = False
    If Target = "YES" Then
        With Sheets("EQUAL")
            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 7).Value = Range("C" & Target.Row).Resize(, 7).Value
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Place this macro in the code module for Sheet1:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String
    Application.EnableEvents = True
    Application.ScreenUpdating = False
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 24
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else: If Target.Value = "" Then GoTo Exitsub Else
                Application.EnableEvents = False
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                  If Oldvalue = "" Then
                    Target.Value = Newvalue
                  Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & vbNewLine & Newvalue
                  Else:
                    Target.Value = Oldvalue
                  End If
                End If
            End If
        Case Is = 20
            If Target = "Yes" Then
                With Sheets("EQUAL")
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 7).Value = Range("C" & Target.Row).Resize(, 7).Value
                End With
            End If
    End Select
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Place this macro in the code module for Sheet4:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 30 Then Exit Sub
    Application.ScreenUpdating = False
    If Target = "Yes" Then
        With Sheets("EQUAL")
            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(, 7).Value = Range("C" & Target.Row).Resize(, 7).Value
        End With
    End If
    Application.ScreenUpdating = True
End Sub