Excel VBA Range.Find

[mrmrf]

Hi.

I was hoping someone could point out where I have gone wrongwith this one.

I have a value of “0” in cell A5 and a value of “2500” incell A55.

I’m using VBA to draw a vertical line from A5 to A55.

I then want to draw a line to intersect the vertical line bymatching a value in Cell M4.

For example, if cell M4=625, the vertical line would be ¼ theway down.

Using help from DanteAmor (forum user) I have tweaked thebelow code for my need, but for some reason it will only work if I have valuesfrom cell A5 to A55 populated evenly and will only exactly match the M4 value.

For example, if M4=200, and 200 appeared within column A it would work. However, if M4 doesn’t match exactly a value in column A, no luck.

Ideally I would like the shapes to intersect the vertical line correctly at the right depth to scale without the need to fill out the column A but I cant see how I have gone wrong

Appreciate any help

Here is also an image

https://ibb.co/jhbCfTy

'Layer one'
    
    Set L1c1 = Range("A:A").Find(Range("M1").Value, LookIn:=xlValues, lookat:=xlWhole)
    Set L1c2 = Range("A:A").Find(Range("M1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not L1c1 Is Nothing Then
        L1cell1 = L1c1.Address
        L1cell2 = L1c2.Address
        Set L1c1 = Range("A:A").Find(Range("M4").Value, LookIn:=xlValues, lookat:=xlWhole)
        Set L1c2 = Range("A:A").Find(Range("M1").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not L1c1 Is Nothing Then
            L1cell2 = L1c1.Address
                        
            L1x1 = Range(L1cell1).Left + Range(L1cell1).Width / 2
            L1y1 = Range(L1cell1).Top + Range(L1cell1).Height / 2
            
            L1x2 = L1x1
            L1y2 = Range(L1cell2).Top
            
            L1y3 = Range("B55").Top + Range("B55").Height / 2
            L1y4 = Range(L1cell2).Top + Range(L1cell2).Height / 2
            
            L1wTotal = Range("M2")
            L1wPoint = Range("M4").Value / L1wTotal
            L1wInter = (L1y2 + L1y1) * L1wPoint
            
            Set L1wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L1x1, L1y1, L1x2, L1y3)
                L1wL.Line.Weight = 1
                L1wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                L1wL.Name = "L1Line1"
        
            Set L1wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L1x1, L1y4, L1x1 + 290, L1y4)
                L1wL.Line.Weight = 1
                L1wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                L1wL.Name = "L1Line2"
                
            L1alto = (L1y4 - L1y1)
            Set L1wL = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, L1x1 + 3, L1y1, 290, L1alto)
                L1wL.TextFrame.Characters.Text = Range("P4").Value
                L1wL.Name = "L1Line3"
    
                                 
'Layer two'
           
    Set L2c1 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
    Set L2c2 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
    Set L2c3 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not L2c1 Is Nothing Then
        L2cell1 = L2c1.Address
        L2cell2 = L2c2.Address
        L2cell3 = L2c3.Address
        Set L2c1 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
        Set L2c2 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
        Set L2c3 = Range("A:A").Find(Range("M5").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not L2c1 Is Nothing Then
            L2cell2 = L1c1.Address
                        
            L2x1 = Range(L2cell1).Left + Range(L2cell1).Width / 2
            L2y1 = Range(L2cell1).Top + Range(L2cell1).Height / 2
            
            L2x2 = L2x1
            L2y2 = Range(L2cell2).Top
            
            L2y3 = Range(L2cell2).Top + Range(L2cell2).Height / 2
            L2y4 = Range(L2cell3).Top + Range(L2cell3).Height / 2
            
            L2wTotal = Range("M2")
            L2wPoint = Range("M5").Value / L1wTotal
            L2wInter = (L2y2 + L2y1) * L2wPoint
            
            Set L2wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L2x1, L2y1, L2x1 + 290, L2y1)
                L2wL.Line.Weight = 1
                L2wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                L2wL.Name = "L2Line2"
                
            L2alto = (L2y1 - L1y4)
            Set L2wL = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, L2x1 + 3, L1y4, 290, L2alto)
                L2wL.TextFrame.Characters.Text = Range("P5").Value
                L2wL.Name = "L2Line3"

 

[pbornemeier]

This line
Set L1c1 = Range("A:A").Find(Range("M4").Value, LookIn:=xlValues, lookat:=xlWhole)
is searching for the exact value in M4 in any cell column A. If that exact value is not found in one of those cells, then, the code won't work.

When you use the values in A5, A55 & M4 to get 1/4, you have to find the y coordinate of the line 1/4 of the way down from A5 point then use that value to plot your text boxes.

Y of A5 point + 0.25 * (Y of A55 point - Y of A5 point) = Y of the text box

 

[pbornemeier]

Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1100813-excel-vba-range-find.html#post5299127

Sub Test_DrawLines()
    
    DrawLines "A5", "A55", "M4"

End Sub

Sub DrawLines(sCell_1 As String, sCell_2 As String, sCell_3 As String)

    'Given 3 cells, draw a line from the first to second and add a text box to the right of the line
    'based on the values in all 3 cells: % from top = M4/(A55-A5) and add text in P5 to text box
    
    Dim aryCellData(1 To 2, 0 To 7) As Variant
    Dim dblPercent As Double
    Dim aryResponse As Variant
    Dim lIndex As Long
    Dim shp As Shape
    Dim dblY As Double
    
    DeleteExistingShapes
    
    dblPercent = Range(sCell_3).Value / ((Range(sCell_2).Value - Range(sCell_1).Value))
    aryResponse = ReturnCellCoords(sCell_1)
        '(Top,Left,Height,Width,Bottom,Right,MidX,MidY) coordinates
        ' 0   1    2      3     4      5     6    7     in a (0,...,7) array
    For lIndex = 0 To 7
        aryCellData(1, lIndex) = aryResponse(lIndex)
    Next
    aryResponse = ReturnCellCoords(sCell_2)
    For lIndex = 0 To 7
        aryCellData(2, lIndex) = aryResponse(lIndex)
    Next
    
    Set shp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
        aryCellData(1, 7), aryCellData(1, 6), _
        aryCellData(2, 7), aryCellData(2, 6)) 'X1,Y1,X2,Y2
    shp.Line.Weight = 1
    shp.Line.ForeColor.RGB = RGB(0, 0, 0)
    shp.Name = "L1Line1"
    
          'Y1                + dblPercent(Y2                - Y1)
    dblY = aryCellData(1, 6) + dblPercent * (aryCellData(2, 6) - aryCellData(1, 6))
    
    Set shp = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
        aryCellData(1, 7) + 3, dblY, 290, aryCellData(2, 2)) 'LTWH
    shp.TextFrame.Characters.Text = Range("P5").Value
    shp.Name = "L2Line3"
    shp.Select
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0

End Sub
Sub Test_ReturnCellCoord()
    Dim x
    x = ReturnCellCoords("C4")
    Stop
End Sub

Private Sub DeleteExistingShapes()

    Dim shp As Shape
    
    Select Case MsgBox("Delete all shapes on worksheet?" & vbLf & _
        "  Yes" & vbTab & " to delete all shapes" & vbLf & _
        "  No" & vbTab & " to leave current shapes there and continue" & vbLf & _
        "  Cancel" & vbTab & " to stop processing.", vbYesNoCancel + vbDefaultButton1, "Delete All Shapes")
    Case vbYes
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next
    Case vbNo
        'Do nothing
    Case Else
        GoTo End_Sub
    End Select
    
End_Sub:
    
End Sub

Function ReturnCellCoords(sAddress As String) As Variant
    'Given the address of a cell (A1) return a array containing the
        '(Top,Left,Height,Width,Bottom,Right,MidX,MidY) coordinates
        ' 0   1    2      3     4      5     6    7     in a (0,...,7) array
        
    Dim rngCell As Range
    Set rngCell = Range(sAddress)
    
    With rngCell
        ReturnCellCoords = Array(.Top, .Left, .Height, .Width, .Top + .Height, .Left + .Width, .Top + (.Height / 2#), .Left + (.Width / 2#))
                                 '0     1      2        3       4               5               6                     7
    End With
    
End Function