VBAマッピング/ Wordの文をExcelの列に転送する

Question

WordのExcelの列 "a"、 "b"、 "c"、 "d"に次の形式の情報を転送して情報を転送しようとしています。エントリのインデックス（この場合は21）

はこれまでのところ、これは私が得たものですが、それが唯一の左上の太字のテキストのためだが、私は取得する方法がわからないフロント他の部分文字列。これに関する助けに感謝します。あなたの例では

Sub TheBoldAndTheExcelful() 
    Dim docCur As Document 
    Dim snt As Range 
    Dim i As Integer 
    'Requires a reference to the 'Microsoft Excel XX.0 Object Library' 
    Dim appXL As Excel.Application, xlWB As Excel.Workbook, xlWS As Excel.Worksheet 

    'This assumes excel is currently closed 
    Set appXL = CreateObject("Excel.Application") 
    appXL.Visible = True 
    Set xlWB = appXL.Workbooks.Add 
    Set xlWS = xlWB.Worksheets(1) 

    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 

    Set docCur = ActiveDocument 

    For Each snt In docCur.Sentences 
    If snt.Bold = True Then 
     i = i + 1 
     xlWS.Cells(i, 1).Value = snt.Text 
    End If 
    Next snt 

ExitHandler: 
    Application.ScreenUpdating = True 
    Set snt = Nothing 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description, vbExclamation 
    Resume ExitHandler 
End Sub 

Answer 1

、

For Each snt In docCur.Sentences 
    If snt.Bold = True Then 
     i = i + 1 
     xlWS.Cells(i, 1).Value = snt.Text 
    End If 
    Next snt 

はあなたが唯一の大胆な文（If snt.Bold = True）を含む、単独でCOLUMN_Aに書いている最初の

For Each snt In docCur.Sentences 
    If snt.Bold = True Then 
     i = i + 1 
     xlWS.Cells(i, COLUMN_A).Value = snt.Text 
    End If 
    Next snt 

ことを書き直してみましょう。あなたがをしたい何

は太字の文とそれの後に続く3つの文章で、あなたは列に書きたいと思います。

だから、このセクションを変更します。

' Dim j As Long ' - make sure to have already declared this, or just uncomment this line 

    For j = 1 to docCur.Sentences.Count ' perhaps docCur.Paragraphs instead? 
    If docCur.Sentences(j).Bold = True Then 
     i = i + 1 
     ' used 1+n and j+n for ease of understanding, but you can make these constant with a real solution; or you could even put this in another loop if you wanted, e.g. For n = 0 to 3, ... 
     xlWS.Cells(i, 1+0).Value = docCur.Sentences(j+0).Text 
     xlWS.Cells(i, 1+1).Value = docCur.Sentences(j+1).Text 
     xlWS.Cells(i, 1+2).Value = docCur.Sentences(j+2).Text 
     xlWS.Cells(i, 1+3).Value = docCur.Sentences(j+3).Text 
    End If 
    Next j 

あるいは、パフォーマンスを最大化する：コメントに基づいて

' Dim j As Long ' - make sure to have already declared this, or just uncomment this line 

    With docCur.Sentences ' perhaps docCur.Paragraphs instead? 
    For j = 1 To .Count 
     If .Item(j).Bold = True Then 
     i = i + 1 
     xlWS.Cells(i, 1).Resize(, 4).Value = Array(.Item(j + 0).Text, .Item(j + 1).Text, .Item(j + 2).Text, .Item(j + 3).Text) 
     End If 
    Next j 
    End With 

、変更内容：

1. を問題：「また、いくつかの私は2番目の行でそれほど技術的に行く文章書式設定から合計5文章になります。 ？実際に同じ文を表現しなければならない」二行連結する方法：
   、ソリューション：&で連結します
   例：
   Array(...)の 4番目の項目は.Item(j + 3).Text & .Item(j + 4).Text)

に .Item(j + 3).Text
から
を変更

2. 問題： "最後の列を作成すると、すべてが面白い見た目の十字で終わりますエジプトのアンキのように）。どのようにそれらを削除する考えですか？「：
   ソリューション：Left(string, Len(string)-1)を使用して、問題文の最後の文字を削除するか、Replace(string, [problem character], "")
   例を使用するか：
   問題の項目（仮定文4）Array(...)でLeft(.Item(j + 3).Text, Len(.Item(j + 3).Text) - 1)

   に.Item(j + 3).Text
   から
   を変更

更新日：

' Dim j As Long ' - make sure to have already declared this, or just uncomment this line 

    With docCur.Sentences ' perhaps docCur.Paragraphs instead? 
    For j = 1 To .Count 
     If .Item(j).Bold = True Then 
     i = i + 1 
     xlWS.Cells(i, 1).Resize(, 4).Value = Array(.Item(j + 0).Text, .Item(j + 1).Text, .Item(j + 2).Text, Left(.Item(j + 3).Text, Len(.Item(j + 3).Text) - 1) & .Item(j + 4).Text) 
     End If 
    Next j 
    End With 

これが完全な修正ではない場合は、サンプルファイルを提供してください。