Arrays 数组拆分和提取

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

---

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

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

---

以下代码将

调试。打印任何给定单元格中带下划线和斜体格式的所有单词：

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
和
下划线的
单词输出到VBE的即时窗口中。如果您想在其他地方使用这些单词，则必须在两个（！）位置调整代码：

在以
InItalicUnderlinedWord
开头的部分中查找单元格中的任何位置，然后
在以
开头的部分中，如果InItalicUnderlinedWord=True和i=Len（j.Value2），则对于单元格中最后一个字符也带有
下划线的
和
斜体

如果您有任何疑问或问题，请告诉我。
稍微简单一点的实现是先复制整个单元格值，然后再操作复制的范围。在循环中调用它，并为其提供两个参数：
rngToCopy
=要复制的单元格和
rngToPaste
目标单元格（符合特定工作簿/工作表的条件）：

这是程序

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

你需要得到最后一个斜体字符等，所以你需要继续你的循环我相信，然后你可以使用中间对不起，忽略这一点，你是按空间分割，你需要粘贴分割值到一个工作表，以做你正在尝试。您可以在已拆分的单元格中使用“查找”或“搜索”来查找每个单词的第一个位置，并进行检查。拆分A1，然后循环数组，得到单词在A1中的位置，然后检查它的第一个字符。我发现你的方法在逻辑上有一些错误，但是你能给出你想要实现的更多细节吗？您想将斜体文本移动到哪里？@David Zemens单元格中有多个单词，我正在将斜体和下划线的单词移动到新的工作表中。移动斜体和下划线的单词，或移动斜体或下划线的单词？同时移动斜体和下划线的单词谢谢！我遇到了一个错误“无法获取range类的characters属性”。你知道这意味着什么吗？只是一个猜测：单元格受到保护和/或工作表（或整个文件）受到保护。如果情况并非如此，那么您可能希望与我们共享给您带来问题的单元格内容。它现在似乎运行正常，但如何更改您建议将单词移动到新工作表的行？取决于您希望将其张贴到哪里。例如：如果要在
工作表（1）
列
A
中添加它们，则在这两种情况下都使用
ThisWorkbook.Worksheets（1）.Cells（ThisWorkbook.Worksheets（1）.Rows.Count，1）.End（xlUp）.Offset（1，0）.Value2
而不是
Debug.Print
。因此，例如，不要使用
Debug.Print Mid（j.Value2，StartPoint，i-StartPoint）
只需使用
thiswoolk.Worksheets（1）.Cells（thiswoolk.Worksheets（1）.Rows.Count，1.End（xlUp）.Offset（1，0.Value2=Mid（j.Value2，StartPoint，i-StartPoint）
。你是说我应该把它放入一个循环？我不完全明白你的意思@DavidZemensCall循环中的过程，正如我在示例中所做的那样。对于…

中的每个cl，第一个代码片段是

。这就是调用
copytalicUnderlined
过程的循环。当然，您需要将新过程添加到VBProject中。因此，在调用（cl，uu其他地方uu）中，我是否只放置要粘贴的位置？是的，
u其他地方uu其他地方
应修改为有效的范围目标。它在两个单元格后运行但停止，并且不会将每个实例拆分为一个新单元格。它似乎只是复制一个单元格，其中一个单词中有下划线。你认为分割单元格，然后使用代码按字符进行操作会有效吗？
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