Macro to look up and post to columns

[philb99]

Hi - Looking for some help please.

I have a membership database which presently I have a macro to to enter details in Col Q and R taken from Sheet 2, ie when I key a Support Contact in Col Q then Col R populates.

I would like to take further information from Sheet 1 and populate it into Sheet 3 based on the detail entered - ie First and Second name when the Support Contact Name is as Row 1 and Support Group Number in as row 2. The list is to go down the respective columns A-U, approx 25 rows of data. The number of support Contacts is presently 21 but will increase.

Dropbox

www.dropbox.com

(Received brilliant help with first macro - https://www.mrexcel.com/board/members/mumps.213217/)

 

[mumps]

In the worksheet code module for Sheet1 try:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 17 Then Exit Sub
    Application.ScreenUpdating = False
    Dim fnd As Range, desWS As Worksheet
    Set desWS = Sheets("Sheet3")
    Select Case Target.Value
        Case "Partner"
            Target.Offset(, 1).Resize(, 2).Value = Array("Not Required", "N/A")
        Case Else
            Set fnd = Sheets("Sheet2").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                Target.Offset(, 1) = fnd.Offset(, 1)
            End If
            With desWS
                Set fnd = .Rows(1).Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1) = Target.Offset(, -13) & " " & Target.Offset(, -12)
                End If
            End With
    End Select
    Application.ScreenUpdating = True
End Sub

 

[philb99]

In the worksheet code module for Sheet1 try:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 17 Then Exit Sub
    Application.ScreenUpdating = False
    Dim fnd As Range, desWS As Worksheet
    Set desWS = Sheets("Sheet3")
    Select Case Target.Value
        Case "Partner"
            Target.Offset(, 1).Resize(, 2).Value = Array("Not Required", "N/A")
        Case Else
            Set fnd = Sheets("Sheet2").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                Target.Offset(, 1) = fnd.Offset(, 1)
            End If
            With desWS
                Set fnd = .Rows(1).Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1) = Target.Offset(, -13) & " " & Target.Offset(, -12)
                End If
            End With
    End Select
    Application.ScreenUpdating = True
End Sub

Really appreciate you helping - I presume that I am replacing the existing Macro with the above
Unfortunately when I key in Partner in Col Q the support Group Name is prefilled as before in Col R and N/A in Col S - Sheet 1 but it is fed into Sheet 3 after all of the headings Col V.
When I then delete all of the Support Contacts in sheet 1 they remain in the Columns in Sheet 3 and also get populated into the column after all of the headings - Col V.

When I delete Partner in Sheet 1 Col Q - Col R input deletes but Col S = N/A remains.

 

[mumps]

When you delete the Support Contacts in Sheet1 , do you want to delete the corresponding data in Sheet3?

 

[philb99]

When you delete the Support Contacts in Sheet1 , do you want to delete the corresponding data in Sheet3?

Yes - I am trying to get to a point whereby the data in sheet 3 is Live - therefore any change in sheet 1 is reflected in sheet 3

 

[mumps]

Will column Q in Sheet1 ever contain duplicate names?

 

[philb99]

Will column Q in Sheet1 ever contain duplicate names?

No

 

[mumps]

Click here to download your file. Please note that in order to do what you requested, I am using column T in Sheet1 as a helper column so please do not use that column. Data will be entered into some cells in that column by the macro. You will not be able to see it because the font in that column is formatted as white. If this is a problem, please let me know and we can choose a different column to act as a helper. This is the code in the worksheet code module.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 17 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim fnd As Range, fnd2 As Range, desWS As Worksheet, rng As Range, rng2 As Range, sName As String
    Set desWS = Sheets("Sheet3")
        For Each rng In Target
            If rng = "" Then
                rng.Resize(, 2).ClearContents
                With desWS
                    Set fnd = .Rows(1).Find(rng.Offset(, 3).Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        sName = rng.Offset(, -13) & " " & rng.Offset(, -12)
                        Set fnd2 = desWS.Columns(fnd.Column).Find(sName, LookIn:=xlValues, lookat:=xlWhole)
                        If Not fnd2 Is Nothing Then
                            fnd2.Delete shift:=xlUp
                            rng.Offset(, 3).ClearContents
                        End If
                    End If
                End With
            Else
                For Each rng2 In Target
                    Target.Offset(, 3) = Target.Value
                    Set fnd = Sheets("Sheet2").Range("A:A").Find(rng2.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        rng2.Offset(, 1) = fnd.Offset(, 1)
                    End If
                    With desWS
                        Set fnd = .Rows(1).Find(rng2.Value, LookIn:=xlValues, lookat:=xlWhole)
                        If Not fnd Is Nothing Then
                            .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1) = rng2.Offset(, -13) & " " & rng2.Offset(, -12)
                        End If
                    End With
                Next rng2
            End If
        Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[philb99]

Click here to download your file. Please note that in order to do what you requested, I am using column T in Sheet1 as a helper column so please do not use that column. Data will be entered into some cells in that column by the macro. You will not be able to see it because the font in that column is formatted as white. If this is a problem, please let me know and we can choose a different column to act as a helper. This is the code in the worksheet code module.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 17 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim fnd As Range, fnd2 As Range, desWS As Worksheet, rng As Range, rng2 As Range, sName As String
    Set desWS = Sheets("Sheet3")
        For Each rng In Target
            If rng = "" Then
                rng.Resize(, 2).ClearContents
                With desWS
                    Set fnd = .Rows(1).Find(rng.Offset(, 3).Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        sName = rng.Offset(, -13) & " " & rng.Offset(, -12)
                        Set fnd2 = desWS.Columns(fnd.Column).Find(sName, LookIn:=xlValues, lookat:=xlWhole)
                        If Not fnd2 Is Nothing Then
                            fnd2.Delete shift:=xlUp
                            rng.Offset(, 3).ClearContents
                        End If
                    End If
                End With
            Else
                For Each rng2 In Target
                    Target.Offset(, 3) = Target.Value
                    Set fnd = Sheets("Sheet2").Range("A:A").Find(rng2.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        rng2.Offset(, 1) = fnd.Offset(, 1)
                    End If
                    With desWS
                        Set fnd = .Rows(1).Find(rng2.Value, LookIn:=xlValues, lookat:=xlWhole)
                        If Not fnd Is Nothing Then
                            .Cells(.Rows.Count, fnd.Column).End(xlUp).Offset(1) = rng2.Offset(, -13) & " " & rng2.Offset(, -12)
                        End If
                    End With
                Next rng2
            End If
        Next rng
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Really appreciate the help but unfortunately it doesn't work - this is because if the Support Contact name changes it doesn't reflect as both old and new are reported - thanks again