excel 通过代码在换行单元格中插入换行符

dw1jzc5e  于 2023-02-10  发布在  其他
关注(0)|答案(5)|浏览(193)

是否可以通过VBA代码在已换行的单元格中插入换行符?(类似于手动输入数据时使用Alt-Enter)
我已通过VBA代码将单元格的自动换行属性设置为True,并且也通过VBA代码向其中插入数据。

sq1bmfud

sq1bmfud1#

是的。AltEnter的VBA等价物是使用换行符:

ActiveCell.Value = "I am a " & Chr(10) & "test"

请注意,这会自动将WrapText设置为True。

  • 证明 *:
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
xmjla07d

xmjla07d2#

你也可以使用vbCrLf,它对应于Chr(13)Chr(10)。正如Andy在下面的评论中提到的,你可能更好地使用ControlChars.Lf

q8l4jmvw

q8l4jmvw3#

有两种方法可以添加换行符:
1.在要添加换行符的字符串中使用VBA中的现有常量(单击here可查看现有vba常量的列表)vbLf,如下所示:

Dim text As String
    
    text = "Hello" & vbLf & "World!"
    
    Worksheets(1).Cells(1, 1) = text

1.使用Chr()函数并传递ASCII字符10以添加换行符,如下所示:

Dim text As String
    
    text = "Hello" & Chr(10) & "World!"
    
    Worksheets(1).Cells(1, 1) = text

在这两种情况下,单元格(1,1)或A1中的输出相同。
查看以下两个线程以了解更多信息:

raogr8fs

raogr8fs4#

我知道这个问题很古老,但我有同样的需求,在搜索了SO和谷歌之后,我找到了一些答案,但没有什么可用的,所以我用这些答案做出了我的解决方案,我在这里分享。

我所需要的

1.已知列宽(以像素为单位)
1.能够以像素为单位测量字符串的长度,以便在列的维度上切割字符串

我发现了什么

1.关于列的像素宽度,我在Excel 2010 DocumentFormat中发现了以下内容:
要在运行时将文件中的width值转换为列宽值(以像素表示),请使用以下计算:=截断(((256 {宽度}+截断(128/{最大位数宽度}))/256){最大位数宽度})即使它是Excel 2010格式,它在Excel 2016中仍然有效。我很快就可以在Excel 365中测试它。
1.关于字符串的像素宽度,我使用了@TravelinGuy in this question提出的解决方案,对错别字和溢出做了一些小的修正。在我写这篇文章的时候,错别字已经在他的答案中得到了修正,但是仍然存在溢出问题。尽管如此,我还是对他的答案进行了评论,所以那里有一切可以让它完美地工作。

我所做的

代码三个递归函数以这种方式工作:
1.功能1:猜测句子的大概剪切位置,以便适合列大小,然后调用函数2和函数3以确定正确的位置。返回原始字符串,其中CR(Chr(10))字符位于适当的位置,以便每行适合列大小。
1.职能二:从一个猜测的地方,尝试添加一些更多的话,而这适合列的大小,
1.职能三:与函数2完全相反,因此它检索句子中的单词,直到适合列大小为止。

代码如下

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

已知限制

只要单元格中的文本只有一种字体和一种字体大小,这段代码就可以工作。这里我假设字体不是粗体也不是斜体,但这可以通过添加几个参数来轻松处理,因为以像素为单位测量字符串长度的函数已经能够做到这一点。我做了很多测试,我总是得到相同的结果比Excel工作表的自动换行功能,但它可能会因Excel版本而异。我认为它可以在Excel 2010上运行,我在2013年和2016年测试过它,并取得了成功。其他版本我就不知道了。如果你需要处理给定单元格内字体类型和/或属性不同的情况,我假设可以通过使用range.caracters属性逐个字符地测试单元格中的文本来实现这一点。它应该会非常慢,但就目前而言,即使将文本拆分为近200行,也只需要不到一个瞬间,因此可能是可行的。

bvk5enib

bvk5enib5#

只需在文本框内按Ctrl + Enter

相关问题