I want to calculate the length of the line, relative to a full line, using VBA. I mean that the last line in the paragraph (when the text is justified) is not full, so I want to calculate the percent that the text fills out of a full line.
I want to calculate the physical size, not the number of characters.
I found that question here, but anyone actually answered...
This is not straight-forward in Word since a "line" is dynamic - it breaks wherever Word thinks it should when it lays out the page. Therefore, only way to determine a "line" is to use the Selection object.
Sub LengthOfLine()
Dim sel As word.Selection
Dim pgSetup As word.PageSetup
Dim iStart, iEnd As Long, dblWidth As Double
Dim dblLineLen As Double
Set pgSetup = sel.Sections(1).PageSetup
dblWidth = pgSetup.PageWidth - pgSetup.LeftMargin - pgSetup.RightMargin
Set sel = Selection
'Get to the front of the line and determine its position
sel.MoveEnd wdLine, -1
iStart = sel.Information(wdHorizontalPositionRelativeToPage)
'Get to the end of the line and determine its position
sel.MoveStart wdLine, 1
sel.MoveEnd wdCharacter, -1
iEnd = sel.Information(wdHorizontalPositionRelativeToPage)
'Calculate the length of the line
dblLineLen = PointsToCentimeters(iEnd - iStart)
Debug.Print "line length: " & dblLineLen
Debug.Print "line space remaining: " & PointsToCentimeters(dblWidth) - dblLineLen
End Sub
Related
This is the output of a program.
I have specified what shall be width of each cell in the program and my program shows correct output.
What I want to do is cell content shall be written from right to left. E.g highlighted figure 9983.54 has width of 21. Text file has used first 7 columns. But I want it to use last 7 columns of text file.
Please see expected output image.
I am not getting any clue how to do this. I am not a very professional programmer but I love coding. This text file is used as input to some other program and i am trying to automate writing text file from excel VBA.
Can anyone suggest a way to get this output format?
Here is the code which gave me first output
Option Explicit
Sub CreateFixedWidthFile(strFile As String, ws As Worksheet, s() As Integer)
Dim i As Long, j As Long
Dim strLine As String, strCell As String
'get a freefile
Dim fNum As Long
fNum = FreeFile
'open the textfile
Open strFile For Output As fNum
'loop from first to last row
'use 2 rather than 1 to ignore header row
For i = 1 To ws.Range("a65536").End(xlUp).Row
'new line
strLine = ""
'loop through each field
For j = 0 To UBound(s)
'make sure we only take chars up to length of field (may want to output some sort of error if it is longer than field)
strCell = Left$(ws.Cells(i, j + 1).Value, s(j))
'add on string of spaces with length equal to the difference in length between field length and value length
strLine = strLine & strCell & String$(s(j) - Len(strCell), Chr$(32))
Next j
'write the line to the file
Print #fNum, strLine
Next i
'close the file
Close #fNum
End Sub
'for example the code could be called using:
Sub CreateFile()
Dim sPath As String
sPath = Application.GetSaveAsFilename("", "Text Files,*.txt")
If LCase$(sPath) = "false" Then Exit Sub
'specify the widths of our fields
'the number of columns is the number specified in the line below +1
Dim s(6) As Integer
'starting at 0 specify the width of each column
s(0) = 21
s(1) = 9
s(2) = 15
s(3) = 11
s(4) = 12
s(5) = 10
s(6) = 186
'for example to use 3 columns with field of length 5, 10 and 15 you would use:
'dim s(2) as Integer
's(0)=5
's(1)=10
's(2)=15
'write to file the data from the activesheet
CreateFixedWidthFile sPath, ActiveSheet, s
End Sub
Something like this should work:
x = 9983.54
a = Space(21-Len(CStr(x))) & CStr(x)
Then a will be 14 spaces followed by x:
a = " 9983.54"
Here 21 is the desired column width --- change as necessary. CStr may be unnecessary for non-numeric x.
If you're going to right-justify a lot of different data to different width fields you could write a general purpose function:
Function LeftJust(val As String, width As Integer) As String
LeftJust = Space(width - Len(val)) & val
End Function
The you call it with LeftJust(CStr(9983.54), 21).
Also note that VBA's Print # statement has a Spc(n) parameter that you can use to produce fixed-width output, e.g., Print #fNum, Spc(n); a; before this statement you calculate n: n = 21-Len(CStr(a)).
Hope that helps
I am getting a runtime error I don't understand in Excel 2011 for Mac under OS X 10.7.5. Here is a summary of the code:
Dim h, n, k as Integer
Dim report as Workbook
Dim r1 as Worksheet
Dim t, newline as String
Dim line() as String
newline = vbCr
'
' (code to get user input from a text box, to select a worksheet by number)
'
ReDim line(report.Sheets.Count + 10)
MsgBox "Array line has " & UBound(line) & " elements." '----> 21 elements
line = split(t, newline)
h = UBound(line)
MsgBox "Array line has " & h & " elements." '----> 16 elements
n = 0
MsgBox TypeName(n) '----> Integer
For k = h To 1 Step -1
If IsNumeric(line(k)) Then
n = line(k)
Exit For
End If
Next k
If n > 0 Then
MsgBox n '----> 7
MsgBox TypeName(n) '----> String
Set r1 = report.Sheets(n) '----> Runtime error "Subscript out of bounds"
So n is declared as an integer, but now VBA thinks it is a string and looks for a worksheet named "7". Is this a platform bug, or is there something I haven't learned yet?
It also surprises me that putting data into the dynamic array reduces its dimension, but perhaps that is normal, or perhaps for dynamic arrays Ubound returns the last used element instead of the dimension, although I have not seen that documented.
The first part of your question is answered by #ScottCraner in the comments - the correct syntax for declaring multiple strongly typed variables on one line is:
Dim h As Integer, n As Integer, k As Integer
'...
Dim t As String, newline As String
So, I'll address the second part of your question specific to UBound - unless you've declared Option Base 1 at the top of the module, your arrays start at element 0 by default, not element 1. However, the Split function always returns a 0 based array (unless you split a vbNullString, in which case you get a LBound of -1):
Private Sub ArrayBounds()
Dim foo() As String
'Always returns 3, regardless of Option Base:
foo = Split("zero,one,two,three", ",")
MsgBox UBound(foo)
ReDim foo(4)
'Option Base 1 returns 1,4
'Option Base 0 (default) returns 0,3
MsgBox LBound(foo) & "," & UBound(foo)
End Sub
That means this line is extremely misleading...
h = UBound(line)
MsgBox "Array line has " & h & " elements."
...because the Array line actually has h + 1 elements, which means that your loop here...
For k = h To 1 Step -1
If IsNumeric(line(k)) Then
n = line(k)
Exit For
End If
Next k
...is actually skipping element 0. You don't really even need the h variable at all - you can just make your loop parameter this...
For k = UBound(line) To LBound(line) Step -1
If IsNumeric(line(k)) Then
n = line(k)
Exit For
End If
Next k
...and not have to worry what the base of the array is.
BTW, not asked, but storing vbCr as a variable here...
newline = vbCr
...isn't necessary at all, and opens the door for all kinds of other problems if you intend that a "newline" is always vbCr. Just use the pre-defined constant vbCr directly.
I have a macro that changes single quotes in front of a number to an apostrophe (or close single curly quote). Typically when you type something like "the '80s" in word, the apostrophe in front of the "8" faces the wrong way. The macro below works, but it is incredibly slow (like 10 seconds per page). In a regular language (even an interpreted one), this would be a fast procedure. Any insights why it takes so long in VBA on Word 2007? Or if someone has some find+replace skills that can do this without iterating, please let me know.
Sub FixNumericalReverseQuotes()
Dim char As Range
Debug.Print "starting " + CStr(Now)
With Selection
total = .Characters.Count
' Will be looking ahead one character, so we need at least 2 in the selection
If total < 2 Then
Return
End If
For x = 1 To total - 1
a_code = Asc(.Characters(x))
b_code = Asc(.Characters(x + 1))
' We want to convert a single quote in front of a number to an apostrophe
' Trying to use all numerical comparisons to speed this up
If (a_code = 145 Or a_code = 39) And b_code >= 48 And b_code <= 57 Then
.Characters(x) = Chr(146)
End If
Next x
End With
Debug.Print "ending " + CStr(Now)
End Sub
Beside two specified (Why...? and How to do without...?) there is an implied question – how to do proper iteration through Word object collection.
Answer is – to use obj.Next property rather than access by index.
That is, instead of:
For i = 1 to ActiveDocument.Characters.Count
'Do something with ActiveDocument.Characters(i), e.g.:
Debug.Pring ActiveDocument.Characters(i).Text
Next
one should use:
Dim ch as Range: Set ch = ActiveDocument.Characters(1)
Do
'Do something with ch, e.g.:
Debug.Print ch.Text
Set ch = ch.Next 'Note iterating
Loop Until ch is Nothing
Timing: 00:03:30 vs. 00:00:06, more than 3 minutes vs. 6 seconds.
Found on Google, link lost, sorry. Confirmed by personal exploration.
Modified version of #Comintern's "Array method":
Sub FixNumericalReverseQuotes()
Dim chars() As Byte
chars = StrConv(Selection.Text, vbFromUnicode)
Dim pos As Long
For pos = 0 To UBound(chars) - 1
If (chars(pos) = 145 Or chars(pos) = 39) _
And (chars(pos + 1) >= 48 And chars(pos + 1) <= 57) Then
' Make the change directly in the selection so track changes is sensible.
' I have to use 213 instead of 146 for reasons I don't understand--
' probably has to do with encoding on Mac, but anyway, this shows the change.
Selection.Characters(pos + 1) = Chr(213)
End If
Next pos
End Sub
Maybe this?
Sub FixNumQuotes()
Dim MyArr As Variant, MyString As String, X As Long, Z As Long
Debug.Print "starting " + CStr(Now)
For Z = 145 To 146
MyArr = Split(Selection.Text, Chr(Z))
For X = LBound(MyArr) To UBound(MyArr)
If IsNumeric(Left(MyArr(X), 1)) Then MyArr(X) = "'" & MyArr(X)
Next
MyString = Join(MyArr, Chr(Z))
Selection.Text = MyString
Next
Selection.Text = Replace(Replace(Selection.Text, Chr(146) & "'", "'"), Chr(145) & "'", "'")
Debug.Print "ending " + CStr(Now)
End Sub
I am not 100% sure on your criteria, I have made both an open and close single quote a ' but you can change that quite easily if you want.
It splits the string to an array on chr(145), checks the first char of each element for a numeric and prefixes it with a single quote if found.
Then it joins the array back to a string on chr(145) then repeats the whole things for chr(146). Finally it looks through the string for an occurence of a single quote AND either of those curled quotes next to each other (because that has to be something we just created) and replaces them with just the single quote we want. This leaves any occurence not next to a number intact.
This final replacement part is the bit you would change if you want something other than ' as the character.
I have been struggling with this for days now. My attempted solution was to use a regular expression on document.text. Then, using the matches in a document.range(start,end), replace the text. This preserves formatting.
The problem is that the start and end in the range do not match the index into text. I think I have found the discrepancy - hidden in the range are field codes (in my case they were hyperlinks). In addition, document.text has a bunch of BEL codes that are easy to strip out. If you loop through a range using the character method, append the characters to a string and print it you will see the field codes that don't show up if you use the .text method.
Amazingly you can get the field codes in document.text if you turn on "show field codes" in one of a number of ways. Unfortunately, that version is not exactly the same as what the range/characters shows - the document.text has just the field code, the range/characters has the field code and the field value. Therefore you can never get the character indices to match.
I have a working version where instead of using range(start,end), I do something like:
Set matchRange = doc.Range.Characters(myMatches(j).FirstIndex + 1)
matchRange.Collapse (wdCollapseStart)
Call matchRange.MoveEnd(WdUnits.wdCharacter, myMatches(j).Length)
matchRange.text = Replacement
As I say, this works but the first statement is dreadfully slow - it appears that Word is iterating through all of the characters to get to the correct point. In doing so, it doesn't seem to count the field codes, so we get to the correct point.
Bottom line, I have not been able to come up with a good way to match the indexing of the document.text string to an equivalent range(start,end) that is not a performance disaster.
Ideas welcome, and thanks.
This is a problem begging for regular expressions. Resolving the .Characters calls that many times is probably what is killing you in performance.
I'd do something like this:
Public Sub FixNumericalReverseQuotesFast()
Dim expression As RegExp
Set expression = New RegExp
Dim buffer As String
buffer = Selection.Range.Text
expression.Global = True
expression.MultiLine = True
expression.Pattern = "[" & Chr$(145) & Chr$(39) & "]\d"
Dim matches As MatchCollection
Set matches = expression.Execute(buffer)
Dim found As Match
For Each found In matches
buffer = Replace(buffer, found, Chr$(146) & Right$(found, 1))
Next
Selection.Range.Text = buffer
End Sub
NOTE: Requires a reference to Microsoft VBScript Regular Expressions 5.5 (or late binding).
EDIT:
The solution without using the Regular Expressions library is still avoiding working with Ranges. This can easily be converted to working with a byte array instead:
Sub FixNumericalReverseQuotes()
Dim chars() As Byte
chars = StrConv(Selection.Text, vbFromUnicode)
Dim pos As Long
For pos = 0 To UBound(chars) - 1
If (chars(pos) = 145 Or chars(pos) = 39) _
And (chars(pos + 1) >= 48 And chars(pos + 1) <= 57) Then
chars(pos) = 146
End If
Next pos
Selection.Text = StrConv(chars, vbUnicode)
End Sub
Benchmarks (100 iterations, 3 pages of text with 100 "hits" per page):
Regex method: 1.4375 seconds
Array method: 2.765625 seconds
OP method: (Ended task after 23 minutes)
About half as fast as the Regex, but still roughly 10ms per page.
EDIT 2: Apparently the methods above are not format safe, so method 3:
Sub FixNumericalReverseQuotesVThree()
Dim full_text As Range
Dim cached As Long
Set full_text = ActiveDocument.Range
full_text.Find.ClearFormatting
full_text.Find.MatchWildcards = True
cached = full_text.End
Do While full_text.Find.Execute("[" & Chr$(145) & Chr$(39) & "][0-9]")
full_text.End = full_text.Start + 2
full_text.Characters(1) = Chr$(96)
full_text.Start = full_text.Start + 1
full_text.End = cached
Loop
End Sub
Again, slower than both the above methods, but still runs reasonably fast (on the order of ms).
I would like to take the count of character from one position until it reaches a Space Using VBA
Sub testing()
Dim YourText As String
YourText = "my name ismanu prasad"
Cells(1, 1).Value = Len(YourText)
End Sub
Above code will return 21 as output. But my scenario is bit different .I need the count of substring “manu” from the above string and output should be 4
Sub Display4thWord()
Dim Space As String
Dim YourText As String
Dim Begin4thWord As Integer
Dim End4thWord As Integer
YourText = "The first message box display a value"
Space = " "
'Find begin of 4th word.
Begin4thWord = InStr(InStr(InStr(1, YourText, Space, vbBinaryCompare) + 1, YourText, Space, vbBinaryCompare) + 1, YourText, Space, vbBinaryCompare)
'Find end of 4th word/begin of 5th word
End4thWord = InStr(Begin4thWord + 1, YourText, Space, vbBinaryCompare)
MsgBox (Begin4thWord)
'Display 4th word
MsgBox (Mid(YourText, Begin4thWord, End4thWord - Begin4thWord))
End Sub
You need to embed InStr function and use with Mid function.
Is it satisfaction you? This solution have hard code number number of word which it will return.
Declare two variables recordnocount & recordnocount
.position is the value we have
recordnocount = InStr(position + 20, text, " ")
recordnocount1 = recordnocount - (position + 20)
we can get the count .
Thankyou All
Is it possible to insert line break in a wrapped cell through VBA code? (similar to doing Alt-Enter when entering data manually)
I have set the cell's wrap text property to True via VBA code, and I am inserting data into it also through VBA code.
Yes. The VBA equivalent of AltEnter is to use a linebreak character:
ActiveCell.Value = "I am a " & Chr(10) & "test"
Note that this automatically sets WrapText to True.
Proof:
Sub test()
Dim c As Range
Set c = ActiveCell
c.WrapText = False
MsgBox "Activcell WrapText is " & c.WrapText
c.Value = "I am a " & Chr(10) & "test"
MsgBox "Activcell WrapText is " & c.WrapText
End Sub
You could also use vbCrLf which corresponds to Chr(13) & Chr(10). As Andy mentions in the comment below, you might be better off using ControlChars.Lf instead though.
Yes there are two ways to add a line feed:
Use the existing constant from VBA (click here for a list of existing vba constants) vbLf in the string you want to add a line feed, as such:
Dim text As String
text = "Hello" & vbLf & "World!"
Worksheets(1).Cells(1, 1) = text
Use the Chr() function and pass the ASCII character 10 in order to add a line feed, as shown bellow:
Dim text As String
text = "Hello" & Chr(10) & "World!"
Worksheets(1).Cells(1, 1) = text
In both cases, you will have the same output in cell (1,1) or A1.
Have a look at these two threads for more information:
What is the difference between a "line feed" and a "carriage return"?
Differences Between vbLf, vbCrLf & vbCr Constants
I know this question is really old, but as I had the same needs, after searching SO and google, I found pieces of answers but nothing usable. So with those pieces and bites I made my solution that I share here.
What I needed
Knowing the column width in pixels
Be able to measure the length of a string in pixels in order to cut it at the dimension of the column
What I found
About the width in pixels of a column, I found this in Excel 2010 DocumentFormat :
To translate the value of width in the file into the column width value at runtime (expressed in terms of pixels), use this calculation:
=Truncate(((256 * {width} + Truncate(128/{Maximum Digit Width}))/256)*{Maximum Digit Width})
Even if it's Excel 2010 format, it's still working in Excel 2016. I'll be able to test it soon against Excel 365.
About the width of a string in pixels, I used the solution proposed by #TravelinGuy in this question, with small corrections for typo and an overflow. By the time I'm writing this the typo is already corrected in his answer, but there is still the overflow problem. Nevertheless I commented his answer so there is everything over there for you to make it works flawlessly.
What I've done
Code three recursive functions working this way :
Function 1 : Guess the approximate place where to cut the sentence so if fits in the column and then call Function 2 and 3 in order to determine the right place. Returns the original string with CR (Chr(10)) characters in appropriate places so each line fits in the column size,
Function 2 : From a guessed place, try to add some more words in the line while this fit in the column size,
Function 3 : The exact opposite of function 2, so it retrieves words to the sentence until it fits in the column size.
Here is the code
Sub SplitLineTest()
Dim TextRange As Range
Set TextRange = FeuilTest.Cells(2, 2)
'Take the text we want to wrap then past it in multi cells
Dim NewText As String
NewText = SetCRtoEOL(TextRange.Value2, TextRange.Font.Name, TextRange.Font.Size, xlWidthToPixs(TextRange.ColumnWidth) - 5) '-5 to take into account 2 white pixels left and right of the text + 1 pixel for the grid
'Copy each of the text lines in an individual cell
Dim ResultArr() As String
ResultArr() = Split(NewText, Chr(10))
TextRange.Offset(2, 0).Resize(UBound(ResultArr) + 1, 1).Value2 = WorksheetFunction.Transpose(ResultArr())
End Sub
Function xlWidthToPixs(ByVal xlWidth As Double) As Long
'Fonction to convert the size of an Excel column width expressed in Excel unit(Range.ColumnWidth) in pixels
'Parameters : - xlWidth : that is the width of the column Excel unit
'Return : - The size of the column in pixels
Dim pxFontWidthMax As Long
'Xl Col sizing is related to workbook default string configuration and depends of the size in pixel from char "0". We need to gather it
With ThisWorkbook.Styles("Normal").Font
pxFontWidthMax = pxGetStringW("0", .Name, .Size) 'Get the size in pixels of the '0' character
End With
'Now, we can make the calculation
xlWidthToPixs = WorksheetFunction.Floor_Precise(((256 * xlWidth + WorksheetFunction.Floor_Precise(128 / pxFontWidthMax)) / 256) * pxFontWidthMax) + 5
End Function
Function SetCRtoEOL(ByVal Original As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW) As String
'Function aiming to make a text fit into a given number of pixels, by putting some CR char between words when needed.
'If some words are too longs to fit in the given width, they won't be cut and will get out of the limits given.
'The function works recursively. Each time it find an End Of Line, it call itself with the remaining text until.
'The recursive process ends whent the text fit in the given space without needing to be truncated anymore
'Parameters : - Original : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
'Return : - The orignal text with CR in place of spaces where the text needs to be cut to fit the width
'If we got a null string, there is nothing to do so we return a null string
If Original = vbNullString Then Exit Function
Dim pxTextW As Long
'If the text fit in, may be it's the original or this is end of recursion. Nothing to do more than returne the text back
pxTextW = pxGetStringW(Original, FontName, FontSize)
If pxTextW < pxAvailW Then
SetCRtoEOL = Original
Exit Function
End If
'The text doesn't fit, we need to find where to cut it
Dim WrapPosition As Long
Dim EstWrapPosition As Long
EstWrapPosition = Len(Original) * pxAvailW / pxTextW 'Estimate the cut position in the string given to a proportion of characters
If pxGetStringW(Left(Original, EstWrapPosition), FontName, FontSize) < pxAvailW Then
'Text to estimated wrap position fits in, we try to see if we can fits some more words
WrapPosition = FindMaxPosition(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
End If
'If WrapPosition = 0, we didn't get a proper place yet, we try to find the previous white space
If WrapPosition = 0 Then
WrapPosition = FindMaxPositionRev(Original, FontName, FontSize, pxAvailW, EstWrapPosition)
End If
'If WrapPosition is still 0, we are facing a too long word for the pxAvailable. We'll cut after this word what ever. (Means we must search for the first white space of the text)
If WrapPosition = 0 Then
WrapPosition = InStr(Original, " ")
End If
If WrapPosition = 0 Then
'Words too long to cut, but nothing more to cut, we return it as is
SetCRtoEOL = Original
Else
'We found a wrap position. We recurse to find the next EOL and construct our response by adding CR in place of the white space
SetCRtoEOL = Left(Original, WrapPosition - 1) & Chr(10) & SetCRtoEOL(Right(Original, Len(Original) - WrapPosition), FontName, FontSize, pxAvailW)
End If
End Function
Function FindMaxPosition(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function that finds the maximum number of words fitting in a given space by adding words until it get out of the maximum space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still fits in the space, it calls itself with a further WrapPosition
'Parameters : - Text : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
' - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)) but inside pxAvailW
'Return : - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0
Dim NewWrapPosition As Long
Static isNthCall As Boolean
'Find next Whitespace position
NewWrapPosition = InStr(WrapPosition, Text, " ")
If NewWrapPosition = 0 Then Exit Function 'We can't find a wrap position, we return 0
If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) < pxAvailW Then '-1 not to take into account the last white space
'It still fits, we can try on more word
isNthCall = True
FindMaxPosition = FindMaxPosition(Text, FontName, FontSize, pxAvailW, NewWrapPosition + 1)
Else
'It doesnt fit. If it was the first call, we terminate with 0, else we terminate with previous WrapPosition
If isNthCall Then
'Not the first call, we have a position to return
isNthCall = False 'We reset the static to be ready for next call of the function
FindMaxPosition = WrapPosition - 1 'Wrap is at the first letter of the word due to the function call FindMax...(...., NewWrapPosition + 1). The real WrapPosition needs to be minored by 1
Else
'It's the first call, we return 0 | Strictly speaking we can remove this part as FindMaxPosition is already 0, but it make the algo easier to read
FindMaxPosition = 0
End If
End If
End Function
Function FindMaxPositionRev(ByVal Text As String, ByVal FontName As String, ByVal FontSize As Variant, ByVal pxAvailW, ByVal WrapPosition As Long) As Long
'Function working backward of FindMaxPosition. It finds the maximum number of words fitting in a given space by removing words until it fits the given space
'The function is inteded to work on text with a "guessed" wrap position that fit in the space allowed
'The function is recursive. Each time it guesses a new position and the word still doesn't fit in the space, it calls itself with a closer WrapPosition
'Parameters : - Text : The text to fit
' - FontName : Name of the font
' - FontSize : Size of the font
' - pxAvailW : Available width in pixels in wich we need to make the text fit
' - WrapPosition : The initial wrap position, positionned someware in the text (WrapPosition < len(Text)), but outside of pxAvailW
'Return : - The position were the text must be wraped to put as much words as possible in pxAvailW, but without getting outside of it. If no position can be found, returns 0
Dim NewWrapPosition As Long
NewWrapPosition = InStrRev(Text, " ", WrapPosition)
'If we didn't found white space, we are facing a "word" too long to fit pxAvailW, we leave and return 0
If NewWrapPosition = 0 Then Exit Function
If pxGetStringW(Left(Text, NewWrapPosition - 1), FontName, FontSize) >= pxAvailW Then '-1 not to take into account the last white space
'It still doesnt fits, we must try one less word
FindMaxPositionRev = FindMaxPositionRev(Text, FontName, FontSize, pxAvailW, NewWrapPosition - 1)
Else
'It fits, we return the position we found
FindMaxPositionRev = NewWrapPosition
End If
End Function
Known limitations
This code will work as long as the text in the cell has only one font and one font size. Here I assume that the font is not Bold nor Italic, but this can be easily handled by adding few parameters as the function measuring the string length in pixels is already able to do it.
I've made many test and I always got the same result than the autowrap function of Excel worksheet, but it may vary from one Excel version to an other. I assume it works on Excel 2010, and I tested it with success in 2013 and 2016. Fo others I don't know.
If you need to handle cases where fonts type and/or attributs vary inside a given cell, I assume it's possible to achieve it by testing the text in the cell character by character by using the range.caracters property. It should be really slower, but for now, even with texts to split in almost 200 lines, it takes less than one instant so maybe it's viable.
Just do Ctrl + Enter inside the text box