VBA mappage/transfert de phrases dans Word à des colonnes dans Excel

Question

J'essaie de transférer des informations du format suivant dans Word à Excel colonnes "a", "b", "c", "d" en ignorant le nombre de avant qui est l'indice de l'entrée (21 dans ce cas)

jusqu'à présent, ce que je suis arrivé, mais il est seulement pour le texte en gras en haut à gauche, mais je ne sais pas comment les autres sous-chaînes. Toute aide avec ceci sera appréciée.

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

Dans votre exemple,

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 

Réécrivons que la première

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 

Vous ne retenant que les gras phrase (If snt.Bold = True), et écrit à COLUMN_A seul.

Qu'est-ce que vous voulez est la phrase audacieuse et les trois phrases qui suivent après, et que vous voulez écrire quatre colonnes.

changer donc cette section:

' 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 

Ou, pour optimiser les performances:

' 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 

Sur la base des commentaires, des changements:

1. Problème: « En outre, certains phrases que je vais un peu sur la deuxième ligne si techniquement là serait 5 phrases au total depuis le formatage. Une manière de concaténer les deux lignes qui devraient effectivement représenter la même phrase ":
   Solution: concaténer &:
   Exemple:
   Quatrième de Array(...) change
   de .Item(j + 3).Text
   à .Item(j + 3).Text & .Item(j + 4).Text)

2. Problème: "Au lieu de créer la dernière colonne, tout se termine par des croix amusantes (comme un Ankh égyptien). Une idée de comment les supprimer?« :
   Solution: Supprimez le dernier caractère dans la phrase problème en utilisant Left(string, Len(string)-1) ou utiliser Replace(string, [problem character], "")
   Exemple:
   élément de problème (en présumant phrase 4) Array(...) change
   de .Item(j + 3).Text
   à Left(.Item(j + 3).Text, Len(.Item(j + 3).Text) - 1)

Mis à jour le:

' 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 

S'il ne s'agit pas d'un correctif complet, veuillez fournir un exemple de fichier.