陣列分割和提取

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。如果你想這些話在其他地方，那麼你就必須在兩個地方調整代碼（！）：

1. 一旦與InItalicUnderlinedWord任何啓動部分中的一個單元格，
2. 內找到任何地方在最後字符在一個單元格中的任何發生也是underlined和italic的部分中以If InItalicUnderlinedWord = True And i = Len(j.Value2) Then開頭。

如果您有任何疑問或問題，請告知我。

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