Member Avatar for tgifgemini

Good people,
I need your assistance.
I have a spreadsheet. My objective is to draw a line after writing each record. The purpose of this is for clarity - to denote the end of each record.

Please see attachment for example of my spreadsheet and where I want the line to be. Note: I drew the line manually.

Below is the module that produced the spreadsheet.

ii = 5
     w = 0
    For Each R In xlWksht.Range("A5:M5"): w = w + R.ColumnWidth: Next
    
    rht = xlWksht.Range("A5").RowHeight
    
    Do Until M.qBW.EOF = True
        ii = ii + 2
        xlWksht.Cells(ii, 1).Value = M.qBW![Req No]
        xlWksht.Cells(ii, 2).Value = M.qBW![Description]
        xlWksht.Cells(ii, 3).Value = M.qBW![ClientName] & Chr(10) & M.qBW![Status]
        xlWksht.Cells(ii, 4).Value = M.qBW![P L] & Chr(10) & M.qBW![TotalProg1Hrs]

        SrchCriteria = "[Name]= " & "'" & M.qBW![Personnel2] & "'"
        rsinPers.FindFirst SrchCriteria
        If rsinPers.NoMatch = False Then
           xlWksht.Cells(ii, 5).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg2Hrs]
        End If
        
        SrchCriteria = "[Name]= '" & M.qBW![Personnel3] & "'"
        rsinPers.FindFirst SrchCriteria
        If rsinPers.NoMatch = False Then
           xlWksht.Cells(ii, 6).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg3Hrs]
        End If
        
        SrchCriteria = "[Name]= '" & M.qBW![Personnel4] & "'"
        rsinPers.FindFirst SrchCriteria
        If rsinPers.NoMatch = False Then
           xlWksht.Cells(ii, 7).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg4Hrs]
        End If
        
        SrchCriteria = "[Name]= '" & M.qBW![Personnel5] & "'"
        rsinPers.FindFirst SrchCriteria
        If rsinPers.NoMatch = False Then
           xlWksht.Cells(ii, 8).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg5Hrs]
        End If
        
        SrchCriteria = "[Name]= '" & M.qBW![Personnel6] & "'"
        rsinPers.FindFirst SrchCriteria
        If rsinPers.NoMatch = False Then
           xlWksht.Cells(ii, 9).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg6Hrs]
        End If
        
        xlWksht.Cells(ii, 10).Value = "-" & Chr(10) & M.qBW.Fields("Per Hrs")
        xlWksht.Cells(ii, 11).Value = M.qBW.Fields("EstimatedTotalHours") & Chr(10) & M.qBW.Fields("Tot Hrs")
        xlWksht.Cells(ii, 12).Value = M.qBW![Start Date] & Chr(10) & M.qBW![Start Date]
        xlWksht.Cells(ii, 13).Value = M.qBW![End Date] & Chr(10) & M.qBW![End  Date]
        xlWksht.Cells(ii + 1, 1).Value = "Comments:" & Chr(10) & "'" & xlApp.Clean(Trim(M.qBW![Comments]))
        
        With xlWksht.Range(Cells(ii + 1, 1), Cells(ii + 1, 5))
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .IndentLevel = 0
            .Font.Size = 10
            .MergeCells = True
            .RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 1).text) - Len("Comments:")) / w + rht + (rht - .Font.Size)
        End With
        M.qBW.MoveNext
    Loop

Thanks,
tgifgemini.

SprdsheetUnderlineRecord.zip (43.64 KB)
  • 2 Contributors
  • 3 Replies
  • 112 Views
  • 1 Day Discussion Span
  • Latest Post Latest Post by tgifgemini

Dani AI

Generated

A cleaner, more reliable way than appending underscores (your Post #2) is to use Excel borders programmatically and avoid Select/Selection (as used). Applying a bottom border to the exact row is stable across fonts and wrapping, and it works whether you have merged cells for the comments or not.

Place this immediately after you finish writing and merging the comment row (so heights/wrap are settled), and replace the repeated Select calls with a direct range reference:

Dim rowNum As Long
Dim underlineRange As Range

rowNum = ii + 1   ' your comments row
Set underlineRange = xlWksht.Range(xlWksht.Cells(rowNum, 1), xlWksht.Cells(rowNum, 13))

With underlineRange.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With

Notes and troubleshooting:

  • If the comments area is merged (your code merges A:E), set the underline across A:M (as above) so the line is continuous across the whole record.
  • Do the border-setting after you call .MergeCells = True and after any row-height adjustment so Excel lays out text first.
  • Avoid Select for speed and reliability. For large result sets, temporarily disable screen updates and automatic calculation (xlApp.ScreenUpdating = False, xlApp.Calculation = xlCalculationManual) and restore them afterwards.
  • If you prefer a framed line (around the whole row) use Range.BorderAround, or use xlDouble/xlThick for a heavier underline as suggested.

Microsoft docs for the methods used: Range.Borders and Range.BorderAround.

Recommended Answers

All 3 Replies

Member Avatar for tgifgemini

Hello,
I tweaked it with the code below to accomplish the above objective, but is there a more efficient way of doing it?

xlWksht.Cells(ii + 1, 1).Value = "Comments:" & Chr(10) & "'" & xlApp.Clean(Trim(M.qBW![Comments])) & Chr(10) & "_____________________________________________________________________________________________________________________________"

tgifgemini.

Member Avatar for QVeen72

Hi,

Check this Code, Write at the end and before the "Loop":

Dim TStr As STring

TStr = "A" & CStr(ii+1) & ":M" & CStr(ii+1)
Range(TStr).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone

REgards
Veena

Member Avatar for tgifgemini

Hi Veena.
Thanks for your input. I do apppreciate it very much.
Have a wonderful weekend.
tgif.

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.