Code optimisation and target range resize

[Celticfc]

Hi all,

My code below allows me to enter active cell contents to D3 (which I use for search/lookup) but I believe there's a lot of repetition and takes 8 seconds to process. Is there a way to paste clicked cell value straight to cell D3?

Also, I want to amend the range from B37:B1000 to the last row with data (i.e. if last row with data is B100, I want the range to change to B37:B100).

Thank you in advance for your support.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.EnableEvents = False
Application.ScreenUpdating = False
Dim iColumn As Integer, jRow As Integer, sAddr, MsgOut As String
Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String
If Not Application.Intersect(Target, Range("B37:B1000")) Is Nothing Then
    sAddr = Target.Address(False, False)
    Cells(35, 2) = "=row(" & sAddr & ")"
    Cells(35, 3) = "=column(" & sAddr & ")"
    jRow = Cells(35, 2)
    iColumn = Cells(35, 3)
    MsgOut = "Would you like to view " & Cells(jRow, iColumn) & "?"
    'MsgBox (MsgOut)
    YesOrNoAnswerToMessageBox = MsgBox(MsgOut, vbYesNo, "Talent FY19")
    If YesOrNoAnswerToMessageBox = vbYes Then
        
         Cells(35, 4) = Cells(jRow, iColumn)
         'Application.Goto ("d3")
         'Range("a1").Select
         Range("d3").Value = Cells(35, 4).Value
         Cells(3, 4).Select
         
         'Application.Goto ActiveCell
    Else
        'MsgBox "Update declined!"
    End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveCell.Select
End Sub

 

[Norie]

Try this.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim YesOrNoAnswerToMessageBox As VbMsgBoxResult
Dim MsgOut As String
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    If Not Application.Intersect(Target, Range("B37:B" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        
        MsgOut = "Would you like to view " & Target.Value & "?"
        YesOrNoAnswerToMessageBox = MsgBox(MsgOut, vbYesNo, "Talent FY19")
        
        If YesOrNoAnswerToMessageBox = vbYes Then
            Range("D3").Value = Target.Value
        End If
        
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

 

[mumps]

See if this does what you want.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim bottomB As Long
    bottomB = Range("B" & Rows.Count).End(xlUp).Row
    If Intersect(Target, Range("B37:B" & bottomB)) Is Nothing Then Exit Sub
    If MsgBox("Would you like to view " & Target & "?", vbYesNo) = vbYes Then
         Cells(35, 4) = Target
         Range("D3") = Target
         Range("D3").Select
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[Celticfc]

Try this.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim YesOrNoAnswerToMessageBox As VbMsgBoxResult
Dim MsgOut As String
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    If Not Application.Intersect(Target, Range("B37:B" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        
        MsgOut = "Would you like to view " & Target.Value & "?"
        YesOrNoAnswerToMessageBox = MsgBox(MsgOut, vbYesNo, "Talent FY19")
        
        If YesOrNoAnswerToMessageBox = vbYes Then
            Range("D3").Value = Target.Value
        End If
        
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

Hi Norie,

This works great however because I have formulas all the way to B1000, it works even in blank cells. How can I get this function to stop working if I select a cell that has formula but no value?

Thank you.

 

[Norie]

Perhaps.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim YesOrNoAnswerToMessageBox As VbMsgBoxResult
Dim MsgOut As String
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    If Not Application.Intersect(Target, Range("B37:B" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        
        If Target.Value = "" Then Exit Sub

        MsgOut = "Would you like to view " & Target.Value & "?"
        YesOrNoAnswerToMessageBox = MsgBox(MsgOut, vbYesNo, "Talent FY19")
        
        If YesOrNoAnswerToMessageBox = vbYes Then
            Range("D3").Value = Target.Value
        End If
        
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub