配列の分割と抽出

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

あなたのループに次のコードを追加する必要がありますので、このような何かが、唯一、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。 （！）：一度任意のセル内の任意の場所を見つけるとで

ためInItalicUnderlinedWordで始まるセクションで

1. あなたはどこか他のこれらの言葉をしたいなら、あなたは2つの場所にコードを調整する必要がありますセル内にが最後に文字がある場合はIf InItalicUnderlinedWord = True And i = Len(j.Value2) Thenで始まり、underlinedとitalicです。

ご質問やご不明な点がありましたら教えてください。

Answer 2

あなたは

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