needed row height

mjcapan

mjcapan

New Member
Joined
Feb 20, 2013
Messages
27
Hello all.
I am working on a macro which draws lines onto a sheet while populating cells. The lines positions are referenced to the center of the cells.

A problem I have encountered is that as data is populated into the cells the row height may be shifted to accommodate additional data. When this happens the line doesn't move which isn't an issue for that line but when I need to connect another line to it I don't have a way to reference its position.

The best possible solution I have come up with so far is to figure out how tall the cell used for the original reference needs to be relative to the data inside. My question then is does excel keep a value of necessary height for the data in a cell, perhaps as a member of the cells or range objects.
If not can I calculate that given the string length and column width.
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Hi,

What are you doing (messing) with lines :) ??? I'm curious as Always.

You can use the properties to know the exact position of the line. The "start" of your line is easy using Left and Top, while the "end" can be calculated using the other properties Height and Width
The following will bug if no shape is selected. It's only meant for testing purposes.
Code: 
Sub shape_info()
Dim shName As String
Dim sh As Shape
Dim msg As String
shName = Selection.Name
Set sh = ActiveSheet.Shapes(shName)
msg = msg & "You just clicked the shape named " & shName & Chr(10)
msg = msg & "(in fact you gave this name to the shape, or didn't change the default)" & Chr(10)
msg = msg & "The codename is:" & sh.Name & Chr(10)
msg = msg & "(Excel assigns codenames for """"internal"""" use)" & Chr(10)
msg = msg & "pixels from top:" & sh.Top & Chr(10)
msg = msg & "pixels from left:" & sh.Left & Chr(10)
msg = msg & "width:" & sh.Width & Chr(10)
msg = msg & "height:" & sh.Height & Chr(10)
MsgBox msg, 46, "SHAPEINFO"
End Sub
kind regards,
Erik
 
Upvote 0
The code I have been working on builds a tree diagram from a table of data the lines connect the various nodes together. I was hoping to go the cell rout to keep things simple. I would have to see if I can work something different with the code to know which line I am connecting to specifically.

The current code I have is below. The issue is specifically with the vertical lines connecting to the horizontal lines when the row height is changed after the horizontal line is placed. The present code looks for the next populated cell above the current cell. If I could tie that into a reference to the line name I could make that work. Any thoughts are appreciated.

Code: 
Public Sub PlotData(ByVal treeLocation As String)


    Dim counter1, counter2, currentRow As Long
    Dim startX, startY, horizEndX, vertStartY, vertEndY As Double
    Dim tempLine As Shape
    Dim dropRow As Boolean
    currentRow = 2
    dropRow = False
    
    ' Move to form to capture data
    Worksheets(treeLocation).Select
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    
    ' Cycle through data
    For counter1 = firstDataRow To lastDataRow


        ' Place node, color it, and border it
        Cells(currentRow, levelNumber(counter1) * 2 + 1) = itemText(counter1)
        Cells(currentRow, levelNumber(counter1) * 2 + 1).Interior.ColorIndex = itemColor(counter1)
        Cells(currentRow, levelNumber(counter1) * 2 + 1).Borders.LineStyle = xlContinuous
        
        ' Check if level is level 1
        If levelNumber(counter1) <> 1 Then
        
            ' If row is dropped then make line half into column before
            If dropRow Then
                startX = Cells(currentRow, levelNumber(counter1) * 2).Left + (Cells(currentRow, levelNumber(counter1) * 2).Width / 2)
                startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
                
                ' Search for top of vertical line
                For counter2 = currentRow - 1 To 2 Step -1
                    If Not IsEmpty(Cells(counter2, levelNumber(counter1) * 2 + 1)) Then
                        vertEndY = Cells(counter2, levelNumber(counter1) * 2 + 1).Top + (Cells(counter2, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                        Exit For
                    End If
                Next counter2
                
                ' Make vertical line
                Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, startX, vertEndY)
                With tempLine
                    .Name = "vertLine" & counter1
                    .Line.ForeColor.RGB = RGB(255, 0, 0)
                    .Line.Weight = 2
                End With
                
            ' Else make line all the way across column before
            Else
                startX = Cells(currentRow, levelNumber(counter1) * 2 + -1).Left + Cells(currentRow, levelNumber(counter1) * 2 + -1).Width
                startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
            End If


            ' Create line,name and format
            Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, horizEndX, startY)
            With tempLine
                .Name = "horizLine" & counter1
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 2
            End With
        End If
        
        ' Check to see if this is the last row of data
        If counter1 <> lastDataRow Then
        
            ' If not last row of data decide whether or not to drop down 2 rows
            If (levelNumber(counter1) >= levelNumber(counter1 + 1)) Then
                currentRow = currentRow + 2
                dropRow = True
            Else
                dropRow = False
            End If
        End If
        
    Next counter1


End Sub
 
Upvote 0
It would be nice to work with something real. Can you upload your workbook somewhere and post the link.
 
Upvote 0
I don't have a way to do that at the moment. Below is the entire code for the process. Pardon the constants at the top I wanted to make it easier for the end users to adapt it as needed. The data table it draws from contains node item numbers in column 1 like: 1.0.0.0.0, 1.1.0.0.0, 1.2.0.0.0.
Column 3 contains text data that is put into the cells of the tree diagram and the referenced disposition column contains text that is used to determine the color of each node on the diagram.

I did come up with a way to fix my lines, though it is not what I would call elegant. I added a section at the end of the plotdata sub which goes back through all the lines and resets their positions back to the center of the rows.

Code: 
' Adjust the values for the constants below to adjust the behavior of the macros


' Where to find the data
Public Const tableSheet As String = "RRCA Inputs"
Public Const nodeColumn As Long = 1
Public Const nodeTextColumn As Long = 3
Public Const nodeDispositionColumn As Long = 15
Public Const firstDataRow As Long = 2


' Where to put the data
Public Const treeSheet As String = "Fault Tree"


' Column widths for tree
Public Const nodeColumnWidth As Long = 14
Public Const spacingColumnWidth As Long = 4


' How to color code the tree. The following website has a table of the potential color options and their numbers
' http://msdn.microsoft.com/en-us/library/office/ff840443.aspx


    ' Level 1 items color
    Public Const firstLevelColor As Long = 3 ' Red
    
    ' Open or no condition
    Public Const openColor As Long = 16 ' Gray
    
    ' First severity level
    Public Const severityCondition1 As String = "Unlikely"
    Public Const conditionColor1 As Long = 4 ' Green
    
    ' Second severity level
    Public Const severityCondition2 As String = "Non Contributor"
    Public Const conditionColor2 As Long = 23 ' Blue
    
    ' Third severity level
    Public Const severityCondition3 As String = "Likely"
    Public Const conditionColor3 As Long = 6 ' Yellow.
    
    ' Fourth severity level
    Public Const severityCondition4 As String = "Finding but Non Contributor"
    Public Const conditionColor4 As Long = 46 ' Orange
    
    ' Fifth severity level
    Public Const severityCondition5 As String = "Contributor"
    Public Const conditionColor5 As Long = 3 ' Red
    
'================================================================================================================
'===================================== DO NOT ADJUST VALUES PAST THIS POINT =====================================
'================================================================================================================
    
' Public data variables used to store table data
Public levelNumber() As Long
Public itemColor() As Long
Public itemText() As String
Public lastDataRow As Long


Sub GenerateFaultTree()
  
    ' If tableSheet exists then grab data
    If DoesSheetExist(tableSheet) Then
        Call GetData(tableSheet)
    
    ' If sheet missing alert user
    Else
        Call MissingSheet(tableSheet)
        Exit Sub
    End If
    
    ' If treeSheet exists then grab data
    If DoesSheetExist(treeSheet) Then
    
        ' Format sheet in preperation for tree build
        Call PreFormatSheet(treeSheet)
        
        ' Build new tree
        Call PlotData(treeSheet)
    
    ' If sheet missing alert user
    Else
        Call MissingSheet(treeSheet)
        Exit Sub
    End If


End Sub


Public Sub GetData(ByVal tableLocation As String)


    Dim counter1, counter2 As Long
    Dim returnSheet As String
    Dim nodeSplit() As String
    returnSheet = ActiveSheet.Name
    
    ' Turns off screen updating and alerts to substantially improve processing speed
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    ' Move to form to capture data
    Worksheets(tableLocation).Select
    
    ' Scrolls to top left to prevent errors
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    
    ' Unhide all to prevent errors
    Cells.EntireRow.Hidden = False
    
    ' Use filter to make sure rows are in the correct order
    Range("A1").AutoFilter
    With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
        .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.AutoFilterMode = False
        
    ' Get last row of table
    lastDataRow = ActiveSheet.Cells(Rows.count, 3).End(xlUp).row
    
    ReDim levelNumber(lastDataRow)
    ReDim itemColor(lastDataRow)
    ReDim itemText(lastDataRow)
    
    ' Cycle through node list
    For counter1 = firstDataRow To lastDataRow
    
        ' Get split out of node #
        nodeSplit = Split(Cells(counter1, nodeColumn), ".")
        
        ' Scan each node split to determine tree level
        For counter2 = UBound(nodeSplit) To 0 Step -1
        
            ' Look for a non 0 value
            If nodeSplit(counter2) <> "0" And nodeSplit(counter2) <> "" Then
                
                ' Get parameters for the data
                levelNumber(counter1) = counter2 + 1
                itemText(counter1) = Cells(counter1, nodeTextColumn)
                
                ' Determine color coding for block
                Select Case Cells(counter1, nodeDispositionColumn)
        
                    Case severityCondition1
                        itemColor(counter1) = conditionColor1
        
                    Case severityCondition2
                        itemColor(counter1) = conditionColor2
        
                    Case severityCondition3
                        itemColor(counter1) = conditionColor3
        
                    Case severityCondition4
                        itemColor(counter1) = conditionColor4
        
                    Case severityCondition5
                        itemColor(counter1) = conditionColor5
        
                    Case Else ' Open or none
                        itemColor(counter1) = openColor
        
                End Select
                
                ' Color level 1 items seperately
                If levelNumber(counter1) = 1 Then
                    itemColor(counter1) = firstLevelColor
                End If
                
                ' Exit for loop
                Exit For
                
            End If
            
        Next counter2
            
    Next counter1
    
    ' Move back to fault tree
    Worksheets(returnSheet).Select
    
    ' Turns screen updating and alerts back on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub


Private Sub PreFormatSheet(ByVal treeLocation As String)


    Dim counter1 As Long
    
    ' Move to form to capture data
    Worksheets(treeLocation).Select
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1


    ' Clear all
    Columns("B:Z").Clear
    
    ' Remove lines from previous tree diagram
    ' Error modifications are there to prevent errors when a particular line does not exist
    On Error Resume Next
    For counter1 = 1 To 1000
        ActiveSheet.Shapes("horizLine" & counter1).Delete
        ActiveSheet.Shapes("vertLine" & counter1).Delete
    Next counter1
    On Error GoTo 0
    
    ' Presize column widths the same. Reduces likely hood of line drawing issues
    Range("C:C,E:E,G:G,I:I,K:K,M:M,O:O,Q:Q,S:S,U:U,W:W,Y:Y").ColumnWidth = nodeColumnWidth
    Range("B:B,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T,V:V,X:X,Z:Z").ColumnWidth = spacingColumnWidth
    
    ' Format Key
    Range("A2").Font.Size = 20
    Range("A3:A4,A5:A6,A7:A8,A9:A10,A11:A12,A13:A14").MergeCells = True
    Range("A2:A14").Font.Bold = True


    ' Create borders
    With Range("A2:A14").Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    ' Generate color key
    Range("A2") = "Color Key"
    Range("A3:A4") = "Open"
    Range("A3:A4").Interior.ColorIndex = openColor
    Range("A5:A6") = severityCondition1
    Range("A5:A6").Interior.ColorIndex = conditionColor1
    Range("A7:A8") = severityCondition2
    Range("A7:A8").Interior.ColorIndex = conditionColor2
    Range("A9:A10") = severityCondition3
    Range("A9:A10").Interior.ColorIndex = conditionColor3
    Range("A11:A12") = severityCondition4
    Range("A11:A12").Interior.ColorIndex = conditionColor4
    Range("A13:A14") = severityCondition5
    Range("A13:A14").Interior.ColorIndex = conditionColor5
    
    ' Center all in cells and turn on wrap text
    With Cells
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With


End Sub


Public Sub PlotData(ByVal treeLocation As String)


    Dim counter1, counter2, counter3, counter4, counter5, counter6, currentTopPosition, currentHeight, currentRow As Long
    Dim startX, startY, horizEndX, vertStartY, vertEndY As Double
    Dim tempLine As Shape
    Dim dropRow As Boolean
    currentRow = 2
    dropRow = False
    
    ' Turns off screen updating and alerts to substantially improve processing speed
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Move to form to capture data
    Worksheets(treeLocation).Select
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    
    ' Cycle through data
    For counter1 = firstDataRow To lastDataRow


        ' Place node, color it, and border it
        Cells(currentRow, levelNumber(counter1) * 2 + 1) = itemText(counter1)
        Cells(currentRow, levelNumber(counter1) * 2 + 1).Interior.ColorIndex = itemColor(counter1)
        Cells(currentRow, levelNumber(counter1) * 2 + 1).Borders.LineStyle = xlContinuous
        
        ' Check if level is level 1
        If levelNumber(counter1) <> 1 Then
        
            ' If row is dropped then make line half into column before
            If dropRow Then
                startX = Cells(currentRow, levelNumber(counter1) * 2).Left + (Cells(currentRow, levelNumber(counter1) * 2).Width / 2)
                startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
                
                ' Search for top of vertical line
                For counter2 = currentRow - 1 To 2 Step -1
                    If Not IsEmpty(Cells(counter2, levelNumber(counter1) * 2 + 1)) Then
                        vertEndY = Cells(counter2, levelNumber(counter1) * 2 + 1).Top + (Cells(counter2, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                        Exit For
                    End If
                Next counter2
                
                ' Make vertical line
                Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, startX, vertEndY)
                With tempLine
                    .Name = "vertLine" & counter1
                    .Line.ForeColor.RGB = RGB(255, 0, 0)
                    .Line.Weight = 2
                End With
                Set tempLine = Nothing
                
            ' Else make line all the way across column before
            Else
                startX = Cells(currentRow, levelNumber(counter1) * 2 + -1).Left + Cells(currentRow, levelNumber(counter1) * 2 + -1).Width
                startY = Cells(currentRow, levelNumber(counter1) * 2 + 1).Top + (Cells(currentRow, levelNumber(counter1) * 2 + 1).RowHeight / 2)
                horizEndX = Cells(currentRow, levelNumber(counter1) * 2 + 1).Left
            End If


            ' Create line,name and format
            Set tempLine = ActiveSheet.Shapes.AddLine(startX, startY, horizEndX, startY)
            With tempLine
                .Name = "horizLine" & counter1
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 2
            End With
            Set tempLine = Nothing
        End If
        
        ' Check to see if this is the last row of data
        If counter1 <> lastDataRow Then
        
            ' If not last row of data decide whether or not to drop down 2 rows
            If (levelNumber(counter1) >= levelNumber(counter1 + 1)) Then
                currentRow = currentRow + 2
                dropRow = True
            Else
                dropRow = False
            End If
        End If
        
    Next counter1
    
    ' The below adjusts all line positions to account for changes in row heights
    ' Error modifications are there to prevent errors when a particular line does not exist
    On Error Resume Next
    
    ' Cycle through lines
    For counter3 = 2 To lastDataRow
    
        ' Fix horizontal lines
        Set tempLine = Nothing
        Set tempLine = ActiveSheet.Shapes("horizLine" & counter3)
        currentTopPosition = tempLine.Top
        
        ' If line exists then find the row in which it lies
        If Not tempLine Is Nothing Then
            For counter4 = lastDataRow To 2 Step -1
            
                ' If row is found adjust line position to half way point of row
                If currentTopPosition > Cells(counter4, 3).Top Then
                    tempLine.Top = Cells(counter4, 3).Top + (Cells(counter4, 3).RowHeight / 2)
                    Exit For
                End If
            Next counter4
        End If
        
        ' Fix vertical lines
        Set tempLine = Nothing
        Set tempLine = ActiveSheet.Shapes("vertLine" & counter3)
        currentTopPosition = tempLine.Top
        currentHeight = tempLine.Height
        
        ' If line exists then find the rows in which its top and bottom points lie
        If Not tempLine Is Nothing Then
        
            ' Search for top point row
            For counter5 = lastDataRow To 2 Step -1
            
                ' If row is found adjust top point of line
                If currentTopPosition > Cells(counter5, 3).Top Then
                    tempLine.Top = Cells(counter5, 3).Top + (Cells(counter5, 3).RowHeight / 2)
                    Exit For
                End If
            Next counter5
            
            ' Search for bottom point row
            For counter6 = lastDataRow To 2 Step -1
            
                ' If row is found adjust bottom point of line
                If (currentTopPosition + currentHeight) > Cells(counter6, 3).Top Then
                    tempLine.Height = (Cells(counter6, 3).Top + (Cells(counter6, 3).RowHeight / 2)) - currentTopPosition
                    Exit For
                End If
            Next counter6
        End If
        
    Next counter3
    On Error GoTo 0
    
    ' Turns screen updating and alerts back on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub


Sub MissingSheet(sheetName As String)
    Call MsgBox("There is no sheet named """ & sheetName & """ in the active workbook. " _
                & vbCrLf & "" _
                & vbCrLf & "This sheet is needed for the operation of this macro. " _
                & vbCrLf & "" _
                & vbCrLf & "If the default name of the sheet the macro is looking for needs " _
                & vbCrLf & "to be changed please update the constant value as the " _
                & vbCrLf & "begining of the source code." _
                , vbExclamation, "Fault Tree Builder")
    
End Sub


Function DoesSheetExist(sheetName As String, Optional workBookName As String) As Boolean


    Dim wSheet As Worksheet
    Dim sChar As Chart
    
    On Error Resume Next
    
    ' Search active workbook
    If workBookName = vbNullString Then
        Set sChar = Charts(sheetName)
        Set wSheet = Sheets(sheetName)
        
    ' Search specific workbook
    Else
        Set sChar = Workbooks(workBookName).Charts(sheetName)
        Set wSheet = Workbooks(workBookName).Sheets(sheetName)
    End If
    
    On Error GoTo 0
    
    ' Return value
    DoesSheetExist = Not sChar Is Nothing Or Not wSheet Is Nothing
    
End Function
 
Upvote 0
A lot of code without sheet to test, is to difficult to work on.
I'll wait till you can upload.

From what I can see here, I think that it might be more elegant to loop through the lines than through the rows, but am not sure.

Another thought: wouldn't it not be more easy to make rules about the font(size), so rowheight won't change?
 
Upvote 0
I meant: you could reset the font and the size within the range where the lines are put to a given font and size.

Downloading your workbook with VBA is not possible (for me). It opens right away as Excel Web App, whatever I try. Rightclicking does lead me nowhere eighter.
Could you please change the name to yourfilename.customending instead of yourfilename.xlsm? Then it won't open but download. Afterwards the name can be changed on the computer.
 
Upvote 0
OK, I can open the workbook.
I ran the Fault Tree code. Looks quite nice. Some details I would do another way.
If they want everything arial 12, you can add that in your code which presets the sheet, not?

Is the user going to change things after the Tree has been build?
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Setting multiple row heights in VBA
Replies
2
Views
175
Extivalis
E
M
  • Question
Merge rows instead of adjusting row height for wrapped text
Replies
0
Views
315
mortensonman
M
V
  • Question
Stop Excel from Auto Resize Row Heights
Replies
5
Views
504
voodoo1226
V
PIsabel
  • Question
past without blanks
Replies
8
Views
163
Alex Blakenburg
A
P
  • Solved
Need help with macro Dynamic Range??
Replies
6
Views
172
pennbowl
P

Forum statistics

Threads
1,214,891
Messages
6,122,105
Members
449,066
Latest member
Andyg666

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top