2 Attachment(s)
[RESOLVED] VB6 - Spreadsheet "MergeCells" formating not working.
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:
Code:
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
Re: VB6 - Spreadsheet "MergeCells" formating not working.
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
Re: VB6 - Spreadsheet "MergeCells" formating not working.
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,
Re: VB6 - Spreadsheet "MergeCells" formating not working.
Depends on the size of the column for display purposes...
Code:
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.
Re: VB6 - Spreadsheet "MergeCells" formating not working.
?Len(Range("A" & 9).value)
6366
?Len(Range("A" & 9).text)
1024
Re: VB6 - Spreadsheet "MergeCells" formating not working.
Excel 2007 has higher limits:
Code:
? 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.
Re: VB6 - Spreadsheet "MergeCells" formating not working.
Quote:
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
Re: VB6 - Spreadsheet "MergeCells" formating not working.
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).
1 Attachment(s)
Re: VB6 - Spreadsheet "MergeCells" formating not working.
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.
Code:
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
Re: VB6 - Spreadsheet "MergeCells" formating not working.
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.
Re: VB6 - Spreadsheet "MergeCells" formating not working.
Hi Anhn,
Below is my complete procedure:
Code:
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
