Locate 2d lines

[SCSabresfan]

Is there a code to line up an existing line to the bottom center or top center of a specific cell? I have a bunch of lines that I change the visibility based of of cell values. I need an easier way to align the lines. My lines are named something similar like LineATop, LineAMiddle and LineABottom

 

[Legacy 143009]

With the setup above, this code will place LineATop to the top of G4 cell, LineAMiddle to the center of J6 cell and LineABottom to the bottom of N8 cell.

Sub test()
  Dim r As Long, c As Long, rowsHeights As Double, columnsWidth As Double
  Dim myDocument As Worksheet
  Dim objLine As Line
  Set myDocument = Worksheets("Sheet1")
 
  With myDocument 'Change here
  For Each objLine In .Lines
    rowsHeights = 0
    columnsWidth = 0
    Select Case objLine.Name
    Case "LineATop"
      For r = 1 To .Range(.Range("A2").Value).Row - 1
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("A2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      objLine.Top = rowsHeights
      objLine.Left = columnsWidth
      Case "LineAMiddle"
      For r = 1 To .Range(.Range("B2").Value).Row - 1
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("B2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      rowsHeights = rowsHeights + (.Cells(r, 1).Height / 2)
      objLine.Top = rowsHeights
      objLine.Left = columnsWidth
      Case "LineABottom"
      For r = 1 To .Range(.Range("C2").Value).Row
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("C2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      objLine.Top = rowsHeights
      objLine.Left = columnsWidth
    End Select
  Next
  End With
End Sub

Please find the sample file below:

WeTransfer - Send Large Files & Share Photos Online - Up to 2GB Free

WeTransfer is the simplest way to send your files around the world

we.tl

 

[Legacy 143009]

One small adjustment for different hicknesses:

Sub test()
  Dim r As Long, c As Long, rowsHeights As Double, columnsWidth As Double
  Dim myDocument As Worksheet
  Dim objLine As Line
  Set myDocument = Worksheets("Sheet1")
  
  With myDocument
  For Each objLine In .Lines
    rowsHeights = 0
    columnsWidth = 0
    Select Case objLine.Name
    Case "LineATop"
      For r = 1 To .Range(.Range("A2").Value).Row - 1
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("A2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      objLine.Top = rowsHeights + (objLine.Border.Weight / 2)
      objLine.Left = columnsWidth
      Case "LineAMiddle"
      For r = 1 To .Range(.Range("B2").Value).Row - 1
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("B2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      rowsHeights = rowsHeights + (.Cells(r, 1).Height / 2)
      objLine.Top = rowsHeights
      objLine.Left = columnsWidth
      Case "LineABottom"
      For r = 1 To .Range(.Range("C2").Value).Row
        rowsHeights = rowsHeights + .Cells(r, 1).Height
      Next
      For c = 1 To .Range(.Range("C2").Value).Column - 1
        columnsWidth = columnsWidth + .Cells(1, c).Width
      Next
      objLine.Top = rowsHeights - (objLine.Border.Weight / 2)
      objLine.Left = columnsWidth
    End Select
  Next
  End With
End Sub