配列分割とvbaエクセルの抽出

Question

私はこのコードで助けを求めましたが、実行すると実行する必要はありません。私は最初のシートの行Cから下線と斜体になっている単語を抽出し、それらを秒シートに移動しようとしています。予想される結果は2番目のイメージにあります。この状況で配列の分割が役に立つのでしょうか？うまくいけば、サンプルデータはより明確になります。

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()は助けることができるが、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 

Answer 2

それはきれいな解決策ではないのですが、あなたは、各セルを取るアレイ内でその内容を置くことができます。その後、部屋を作り、「荷を降ろして」移動してください。

私はいくつかの単純なデータでテストしていますが、エラーが発生した場合は、テキスト/データのより多くの例を示すことができますか？

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

を

私はこれがうまくいくはずだと思います - 私はあなたの例に合うようにあなたのコードを修正しました。あなたがシートにSet rge = ws1.Range("C8:C100") にチェックするために

細胞の変化範囲を、あなたの実際の生活のシートに合わせて、ワークシートの2人の

変更の名前を を追加開始したい場所をマークする

• 変更トップ定数

  コード例：

  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