数组分割和提取 VBA Excel

Question

我得到了这段代码的帮助，但是当它运行时，它没有执行它需要做的事情。我正在尝试从第一个工作表的C行中提取被下划线和斜体标记的单词，并将它们移动到第二个工作表。预期结果如第二张图片所示。在这种情况下，数组拆分是否有用？希望示例数据能更清楚地说明问题。

Sub proj()


For Each cl In Range("C1:C5")
        Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1"))
    Next

End Sub

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

- johndoe253

---

看起来很复杂。你只想查看实际单词而不包括标点符号 - 你还想查看格式。可能需要某种正则表达式，然后能够根据单元格中单词的位置查看格式。 - dbmitch

使用您的定义添加示例代码 - 无需正则表达式。 - dbmitch

你没有在循环中更改目标范围。如果你这样做，Sheet2上只会有一个输出值... - David Zemens

Answer 1

这不是最好的解决方案，但您可以将每个单元格的内容放入数组中。然后，腾出一些空间，"卸载它们"并继续执行。

我用一些简单的数据进行了测试，但如果您有错误，请展示更多的文本/数据示例？

Sub proj()
Dim cl      As Range
Dim x       As Long

x = 0

For Each cl In Sheets("Sheet1").Range("C1:C5")
    Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1").Offset(x, 0))
    x = x + 1
Next
Call breakOutWords
End Sub

Sub CopyItalicUnderlined(rngToCopy As Range, rngToPaste As Range)
Dim foundWords() As Variant

rngToCopy.Copy rngToPaste

Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
    With rngToPaste.Characters(i, 1)
        Debug.Print .Text
        If Not .Font.Italic And Not .Font.Underline Then
            If .Text <> " " Then
                .Text = vbNullString
            Else
                .Text = " "
            End If
        End If
    End With
Next
rngToPaste.Value = Trim(rngToPaste.Value)
rngToPaste.Value = WorksheetFunction.Substitute(rngToPaste, "  ", " ")


End Sub
Sub breakOutWords()
Dim lastRow As Long, i As Long, k As Long, spaceCounter As Long
Dim myWords As Variant
Dim groupRange As Range

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastRow To 1 Step -1
    ' Determine how many spaces - this means we have X+1 words
    spaceCounter = Len(Cells(i, 1)) - Len(WorksheetFunction.Substitute(Cells(i, 1), " ", "")) + 1
    If spaceCounter > 1 Then
        Set groupRange = Range(Cells(i, 1), Cells(WorksheetFunction.Max(2, i + spaceCounter - 1), 1))
        groupRange.Select
        myWords = Split(Cells(i, 1), " ")
        groupRange.Clear
        For k = LBound(myWords) To UBound(myWords)
            groupRange.Cells(1 + k, 1).Value = myWords(k)
        Next k
    Else
        ' how many new rows will we need for the next cell?
        Dim newRows As Long
        newRows = Len(Cells(i - 1, 1)) - Len(WorksheetFunction.Substitute(Cells(i - 1, 1), " ", ""))
        Range(Cells(i, 1), Cells(i + newRows - 1, 1)).EntireRow.Insert
    End If
Next i

End Sub

- BruceWayne

---

感谢您抽出时间。 - johndoe253

@johndoe253 - 这很有趣，好问题。 - BruceWayne

Answer 2

Split()可以帮助，但只有在您已经找到并解析了斜体字后才能使用，因为Characters()方法只能在Range对象上调用

然后您可以尝试以下代码：

Option Explicit

Sub proj()
    Dim dataRng As range, cl As range
    Dim arr As Variant

    Set dataRng = Worksheets("ItalicSourceSheet").range("C1:C5") '<--| change "ItalicSourceSheet" with your actual source sheet name
    With Worksheets("ItalicOutputSheet") '<--|change "ItalicOutputSheet" with your actual output sheet name
        For Each cl In dataRng
            arr = GetItalics(cl) '<--| get array with italic words
            If IsArray(arr) Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr) '<--| if array is filled then write it down to output sheet first blank cell in column "A"
        Next
    End With
End Sub

Function GetItalics(rng As range) As Variant
    Dim strng As String
    Dim iEnd As Long, iIni As Long, strngLen As Long

    strngLen = Len(rng.Value2)
    iIni = 1
    Do While iEnd <= strngLen
        Do While rng.Characters(iEnd, 1).Font.Italic And rng.Characters(iEnd, 1).Font.Underline
            If iEnd = strngLen Then Exit Do
            iEnd = iEnd + 1
        Loop
        If iEnd > iIni Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"
        iEnd = iEnd + 1
        iIni = iEnd
    Loop
    If strng <> "" Then GetItalics = Split(Left(strng, Len(strng) - 1), "|")
End Function

- user3598756

---

谢谢！只是想澄清一下，我该如何将它移动到从V4开始？ - johndoe253

V4应该从什么开始？ - user3598756

Answer 3

我认为这应该可以工作-我修改了您的代码以匹配您的示例。

• 更改顶部常量以标记您想要开始附加到Sheet 2的位置
• 更改工作表名称以匹配您的实际工作表
• 更改要检查的单元格范围Set rge = ws1.Range("C8:C100")

示例代码：

Option Explicit

Public Sub ExtractUnderlinedItalicizedWords()

    ' Where to start appending new words '
    Const INSERT_COL        As Integer = 1
    Const START_AT_ROW      As Integer = 1

    Dim ws1         As Worksheet
    Dim ws2         As Worksheet

    Dim rge         As Range
    Dim cel         As Range
    Dim c           As Object

    Dim countChars  As Integer
    Dim i           As Integer
    Dim intRow      As Integer        
    Dim strWord     As String

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    intRow = START_AT_ROW

    ' Define the range of cells to check
    Set rge = ws1.Range("C8:C100")

    For Each cel In rge.Cells
        countChars = cel.Characters.count
        ' Only do this until we find a blank cell
        If countChars = 0 Then Exit For

        strWord = ""

        For i = 1 To countChars
            Set c = cel.Characters(i, 1)
            With c.Font
                If (.Underline <> xlUnderlineStyleNone) And (.Italic) Then
                    strWord = strWord & c.Text
                Else
                    If Len(strWord) > 0 Then
                        ws2.Cells(intRow, INSERT_COL).Value = strWord
                        intRow = intRow + 1
                        strWord = ""
                    End If
                End If
            End With
        Next i

        ' Get Last Word in cell
        If Len(strWord) > 0 Then
            ws2.Cells(intRow, INSERT_COL).Value = strWord
            intRow = intRow + 1
            strWord = ""
        End If

    Next ' Next cell in column range        

End Sub   

- dbmitch