数组分割和提取VBA的Excel

我得到了这个代码的帮助，但是当它运行时，它不执行它需要做的事情。 我试图从第一个表格的C行中提取加下划线和斜体的单词，并将它们移到秒表上。 预期的结果是在第二个图像。 在这种情况下arrays分裂会被使用吗？ 希望样本数据更清楚。

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

Split()可以提供帮助，但是只有在你已经发现并parsing了斜体字之后，才可以在Range对象上调用Characters()方法

你可以尝试下面的代码：

 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 

Answer 2

这不是最漂亮的解决scheme，但是你可以把每个单元格放在一个数组中。 然后，腾出一些空间，然后“卸载它们”并移动。

我testing了一些简单的数据，但如果你有错误，你能显示更多的文本/数据的例子吗？

 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 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