Question

我尝试遍历单元格中的每个字符，以确定单词是否加下划线和斜体，但到目前为止循环运行并冻结。如何复制和移动斜体和下划线的单词？这就是我到目前为止所拥有的。我问了一个新问题，因为我在这个问题上不够清楚。可以在Array split and extract vba excel访问它。

For Each j In ActiveSheet.Range("C1:C105")
        v = Trim(j.Value)
        If Len(v) > 0 Then
            v = Replace(v, vbLf, " ")

            Do While InStr(v, "  ") > 0
                v = Replace(v, "  ", " ")
            Loop

            arr = Split(v, " ")

            For Z = LBound(arr) To UBound(arr)
            e = arr(Z)

                For i = 1 To Len(v)
                    If j.Characters(i, 1).Font.Italic = True And j.Characters(i, 1).Font.Underline = True Then
                        j.Value.Copy


                    End If
                Next i
            Next Z
        End If
   Next j

Answer 1

以下代码将Debug.Print所有在任何给定单元格中带下划线和格式化为斜体的单词：

Option Explicit

Public Sub tmpSO()

Dim i As Long
Dim j As Range
Dim StartPoint As Long
Dim InItalicUnderlinedWord As Boolean

For Each j In ThisWorkbook.Worksheets(1).Range("C1:C105")
    If Len(j.Value2) > 0 Then
        For i = 1 To Len(j.Value2)
            If j.Characters(i, 1).Font.Italic And j.Characters(i, 1).Font.Underline Then
                If InItalicUnderlinedWord = False Then
                    StartPoint = i
                    InItalicUnderlinedWord = True
                End If
            Else
                If InItalicUnderlinedWord = True Then
                    Debug.Print Mid(j.Value2, StartPoint, i - StartPoint)
                    InItalicUnderlinedWord = False
                End If
            End If
            If InItalicUnderlinedWord = True And i = Len(j.Value2) Then
                Debug.Print Mid(j.Value2, StartPoint, i - StartPoint + 1)
                InItalicUnderlinedWord = False
            End If
        Next i
    End If
Next j

End Sub

Debug.Print会将italic和underlined字输出到VBE的即时窗口中。如果你想在其他任何地方使用这些单词，那么你必须在两个（！）位置调整代码：

进入以InItalicUnderlinedWord开头的部分，查找单元格内的任何查找位置
在以If InItalicUnderlinedWord = True And i = Len(j.Value2) Then开头的部分中，对于单元格中最后字符同时为underlined和italic的任何事件。

如果您有任何问题或疑问，请与我们联系。

Answer 2

像这样的东西，只有1个单元格，所以你需要将它添加到你的循环中

Sub test()

Dim r As Range
Dim v As Variant
Dim i As Integer
Dim f As Integer

Set r = Range("h2")
v = Split(r.Value, Chr(32))

For i = 0 To UBound(v) - 1

    f = InStr(1, r, v(i))     ' equiv Application.WorksheetFunction.Search(v(i), r)

    If r.Characters(f, 1).Font.Italic Then
        Debug.Print v(i) & " is italic"
    End If

Next i

End Sub

Answer 3

稍微简单的实现涉及首先复制整个单元格值，然后操纵复制的范围。在循环中调用它，并为它提供两个参数：rngToCopy =正在复制的单元格和rngToPaste目标单元格（限定为特定的工作簿/工作表）：

For each cl in Range("C1:C105")
    Call CopyItalicUnderlined(cl, __Some Place Else__)
Next

这是程序

Sub CopyItalicUnderlined(rngToCopy, rngToPaste)

rngToCopy.Copy rngToPaste

Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
    With rngToPaste.Characters(i, 1)
        If Not .Font.Italic And Not .Font.Underline Then
            .Text = vbNullString
        End If
    End With
Next


End Sub

数组拆分和提取

3 个答案: