[RESOLVED] VB6 - Spreadsheet "MergeCells" formating not working.

[Giftx]

Hello everybody,
Mr. Westconn1 and others assisted me in formating one spreadsheet. Now I am using similar code and technique to format another spreadsheet, but it is not working. Maybe there is something I'm doing incorrectly on the code. My objective is to split a record, write 90% of the record on one row and write the remaining 10% on the next row(right underneath the other half).

I have attached two spreadsheets: The first spreadsheet is correctly formated and the second is Unformated. I want to format the second spreadsheet to look like the first.

See my module below:

    ii = 5
    w = 0
    For Each R In xlWksht.Range("A13:M13"): w = w + R.ColumnWidth: Next
    
    rht = xlWksht.Range("A6").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]))
        
        M.qBW.MoveNext
    Loop
    
    With xlWksht.Range(Cells(ii + 1, 1), Cells(ii + 1, 13))
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .IndentLevel = 0
            .MergeCells = True
            .RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 1).text) - Len("Comments:")) / w + rht + (rht - .Font.Size)
    End With

Thanks,
GiftX

[westconn1]

maybe there is some limitation in excel as to how much text can be displayed in non edit mode,

even when the rowheight is great enough the text does not all display until in edit mode

[anhn]

Gift,

Two weeks ago, on one of my posts on your thread, I already mentioned the display problem of long text in an Excel cell.
http://vbforums.com/showpost.php?p=2971672&postcount=10
At that moment, you were too happy with the way westconn1 helping you so you ignored my post, that did not bother me. (Sorry "west", I have no problem with you.)

The number of "500" in that post was not exactly as I wrote, it is likely after 1024 characters, the text in the cell does not wrap anymore even you expand the row height. That is understandable, an Excel cell is not a document like Word. It must have some limit, but the problem is that limit is sometime too small to someone.

If you are working with Access and Excel and if you wish, post your database here, when I have time I will help you on this with a complete coding from A to Z.

Please note that your first linked zip file is corrupted.
Cheers,

[Ecniv]

Depends on the size of the column for display purposes...

Public Sub ss()
    Dim sht As Worksheet
    
    Dim lngLoop As Long
    Dim strHeld As String
    
    Set sht = ActiveSheet
    
    For lngLoop = 1 To 2048
        If lngLoop Mod 10 = 0 Then
            strHeld = Left(strHeld, Len(strHeld) - Len(CStr(lngLoop))) & CStr(lngLoop)
        Else
            strHeld = strHeld & "0"
        End If
    Next
    sht.Cells(1, 1) = strHeld
    
    Set sht = Nothing
End Sub

Dropped the above code in excel (module) and ran it. If the column was thin (24.57) shows to 640(ish) characters.
If large (124.86) shows to 1350 ish characters.
I'm using Excel 2003 - appears to hold up to 8192 characters (perhaps more). Just doesn't dsplay them all.

[westconn1]

?Len(Range("A" & 9).value)
6366
?Len(Range("A" & 9).text)
1024

[anhn]

Excel 2007 has higher limits:

? Len(Sheet1.Range("E900").Value)
 9000 
? Len(Sheet1.Range("E900").Text)
 8221 
? Mid(Sheet1.Range("E900").Text, 8215,30)
008220 
? Mid(Sheet1.Range("E900").Value, 8215,30)
008220 000008230 000008240 000

Cell.value can hold up to 32767 chars,
max column width = 255
max row height = 409.5

With this width and height limits, depend on font style and size, you may see more or less up to 32767 chars.
with font Arial size 8, on 1280 resolution screen, you can see less than 8000 chars.

The problem of non-wrap text was fixed in Excel-2007.

[westconn1]

Excel 2007 has higher limits:

i am still using 2000 and am unlikely to upgrade any time soon
i use it more for writing sample code than making workbooks

[anhn]

I know. Me too, I use both 2000 & 2003 at work, 2007 at home.
I mentioned 2007 because as I said earlier, the limit depends on version of Excel, now I just want to find out.
I have to deal with this everyday at work as I have to produce 1200 well-formated Excel reports a week,
(people at work do not know that it takes me only 25 minutes in Monday morning without even one single keystroke).

[Giftx]

Hi Anhn,
Please, do not be offended. I owe greate gratitude to all of you, for your very valuable expertise and posts. It's just that Mr. West have been holding my hand and guiding me through before you came on the scene with your expertise - Again, I do appreciate every input. I just wish there's a way I can take you guys out for a drink

Down to business: I tweaked my code and re-ran the module. As you can see from the attachment,only the first record formats correctly, but the rest of the records are all bunched up on the left corner(on the next row). Maybe my calculation is wrong or something.
Note: the underlined codes in the module below shows the changes I made from the working module.
Also see attachment for sample spreadsheet.

ii = 5
    w = 0
    For Each R In xlWksht.Range("A13:M13"): w = w + R.ColumnWidth: Next
    
    rht = xlWksht.Range("A6").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]))
        xlWksht.Cells(ii + 1, 1).Value = "Comments:" & Chr(10) & "'" & xlApp.Clean(Trim(M.qBW![Comments]))
        
        M.qBW.MoveNext
    Loop
    
    With xlWksht.Range(Cells(ii + 1, 1), Cells(ii + 1, 13))
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .IndentLevel = 0
            .Font.Size = 9
            .MergeCells = True
            .RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 1).text) - Len("Comments:")) / w + rht + (rht - .Font.Size)
    End With

Thanks,
GiftX

[anhn]

Quick reply:

* On calculating column widths, you can use any row number:
Range("A13:M13") or Range("A1:M1") gives you the same result.

* Only one row gives you merge cells because you put the "merge" block of code outside the loop.

* It will be easier for people to help you, you shoud post a complete procedure (sub or function) from first to last lines with everything in it.

[Giftx]

Hi Anhn,
Below is my complete procedure:

Private Function BiWeeklyPeriodProgExportCriteria()
    'On Error GoTo Errorhandler
    Dim recordcnt As Long
    Dim SrchCriteria As String
    Dim P As Integer
    Dim R As Range
    Dim w As Long
    Dim rht As Long
    
    Set M.qBW = M.DB.OpenRecordset("qBiWeeklyPeriodProgrammer", dbOpenDynaset)
    Set rsinPers = M.DB.OpenRecordset("TblPersonnel", dbOpenDynaset)
    Set rsSrtSelStr = M.DB.OpenRecordset("TblSelectionString", dbOpenDynaset)
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlWbk = xlApp.Workbooks.Open("C:\BiWeeklyPeriodProg.xls")
    Set xlWksht = xlWbk.Worksheets(1)
    
    xlWksht.Activate
    xlWksht.UsedRange.ClearContents
    
    xlWksht.Cells(2, 1).Value = rsSrtSelStr![SelectionString]
    xlWksht.Cells(3, 1).Value = rsSrtSelStr![SortString]
    
    xlWksht.Range("A2:F2").MergeCells = True
    xlWksht.Range("A3:F3").MergeCells = True
    
    'Write Spreadsheet headers:
    '--------------------------
    ii = 4
    ii = ii + 1
    xlWksht.Cells(ii, 1).Value = "Req No"
    xlWksht.Cells(ii, 2).Value = "Description"
    xlWksht.Cells(ii, 3).Value = "Client Name" & Chr(10) & "& Status"
    xlWksht.Cells(ii, 4).Value = "PL" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 5).Value = "Pr2" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 6).Value = "Pr3" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 7).Value = "Pr4" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 8).Value = "Pr5" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 9).Value = "Pr6" & Chr(10) & "Hrs"
    xlWksht.Cells(ii, 10).Value = "Current"
    xlWksht.Cells(ii, 11).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Tot Hrs"
    xlWksht.Cells(ii, 12).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Start Date"
    xlWksht.Cells(ii, 13).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "End Date"
     
    'Format spreadsheet headers:
    '---------------------------
    xlWksht.Range("A5:M5").Select
    With Selection.Font
        .FontStyle = "Bold"
        .Size = 8
        .Underline = xlUnderlineStyleDouble
    End With
    
    xlWksht.Rows("5:5").RowHeight = 42.75
    xlWksht.Columns("D:H").ColumnWidth = 5
    xlWksht.Columns("K:M").ColumnWidth = 11
    xlWksht.Columns("B").ColumnWidth = 27
    xlWksht.Columns("C").ColumnWidth = 10
    
         
    'Gift Modified Module:
    '----------------
    M.qBW.MoveFirst
    rsinPers.MoveFirst
    recordcnt = 0
    
    ii = 5
    w = 0
    For Each R In xlWksht.Range("A13:M13"): w = w + R.ColumnWidth: Next
    
    rht = xlWksht.Range("A6").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]))
        xlWksht.Cells(ii + 1, 1).Value = "Comments:" & Chr(10) & "'" & xlApp.Clean(Trim(M.qBW![Comments]))
        
        M.qBW.MoveNext
    Loop
    
    With xlWksht.Range(Cells(ii + 1, 1), Cells(ii + 1, 13))
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
            .Orientation = 0
            .IndentLevel = 0
            .Font.Size = 9
            .MergeCells = True
            .RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 1).text) - Len("Comments:")) / w + rht + (rht - .Font.Size)
    End With

Thanks,
GiftX