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

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

Answer 2

// Instead of using setInterval in a bluebird promised environment... setInterval(doStuffA, 1000*60*60); // 1x/1h // I would have liked a full promise chain, but as jfriend00 stated, // It will end up crashing because the initial promise is never resolved... function runA() { return doStuffA() .timeout(1000*60*30) // kill the running instance if it takes longer than 30min .delay(1000*60*60) // wait 60min .then(runA, runA); // whatever the outcome, restart the process } runA(); // Therefore, a solution like jfriend00's seems like the way to go : function runA() { setTimeout(function() { doStuffA() .timeout(1000*60*30) .then(runA, runA) }, 1000*60*60); } runA();可以提供帮助，但只有在您已经找到并解析斜体字之后，Split()方法才能在Characters()对象上调用

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

Range

Answer 3

我认为这应该有用 - 我修改了你的代码以匹配你的例子。

更改顶部常量以标记要开始追加的位置到表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

数组拆分并提取vba excel

3 个答案: