Come temevo, lavorare su un file word scritto praticamente a mano libera porta solo a risultati probabili...
L'aspetto su cui la fantasia dello scrivente e' mortale (dal punto di vista di "programmare" una azione) e' individuare quale e' il testo descrittivo da riportare nel file Excel.
Queste aree non sono contraddistinte da bookmark, ne' hanno una formattazione prevedibile (nell'esempio pubblicato hanno stile o "Normale" oppure "Paragrafo elenco"), ne' ce l'hanno i paragrafi adiacenti, ne' e' nota la spaziatura rispetto alle tabelle (gli elementi certi di facile individuazione).
Ho pertanto ripiegato su questa logica:
-dopo aver individuato una tabella, da cui si preleva il "codice gerarchico" (es Codice 000001.1) e la sua descrizione (es Il mare), il testo descrittivo di quel codice gerarchico sara' individuato dal "primo paragrafo utile" che segue la tabella (nell'esempio: "Il primo capitolo introduce la storia del vecchio pescatore, parlando del suo rapporto con il mare e con Manolin, il ragazzo che era solito aiutarlo").
Se la descrizione si estende su piu' di 1 paragrafo, solo il primo paragrafo verra' prelevato. Un paragrafo termina col tasto Enter; un eventuale Maiusc-Enter invece inserisce un "A capo" e fa continuare il paragrafo sulla riga successiva.
Con questa rilevante limitazione, si potra' usare questa macro:
- Codice: Seleziona tutto
Sub WordSummary()
Dim TabNum As Long, I As Long, CLine As Long, NxLine As Long, myDoc As Document
Dim dRan As Range, TData, TRData, NrRows As Long, NrCols As Long, IStyle
Dim XlApp, XlWb
Set myDoc = ActiveDocument
TabNum = myDoc.Tables.Count
Set XlApp = CreateObject("excel.application")
XlApp.Visible = True
Set XlWb = XlApp.Workbooks.Add 'Open("C:\Users\Utente1\Documents\VALLE_PROT.xlsx") '<<< Il vero percorso del file XL
For I = 1 To TabNum
With myDoc.Tables(I)
Set dRan = .ConvertToText(Separator:=vbTab, _
NestedTables:=False)
TData = dRan.Text
'Restore:
myDoc.Undo
'Cerca ultima riga & ultima cella:
TData = Mid(TData, 1, Len(TData) - 1)
RData = Split(TData, vbCr)
NrRows = UBound(RData, 1) 'UBOUND delle righe
TRData = Split(RData(NrRows), vbTab, , vbBinaryCompare)
NrCols = UBound(TRData)
If NrCols > 0 Then
' crow = Selection.Information(wdFirstCharacterLineNumber)
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
IStyle = Selection.Style
Do
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
If Len(Selection.Text) > 5 Then Exit Do
Loop
mytag = TRData(NrCols)
mytext = TRData(NrCols - 1)
mylev = Len(mytag) - Len(Replace(mytag, ".", "", , , vbBinaryCompare))
mynext = NextR(XlWb.sheets(1), 6)
XlWb.sheets(1).Cells(mynext, 2 + 2 * mylev).Value = mytag & Chr(10) & Chr(10) & Selection.Text
XlWb.sheets(1).Cells(mynext, 1 + 2 * mylev).Value = mytext
End If
End With
Next I
'
Set XlApp = Nothing
MsgBox ("Completato..." & vbCrLf & "Formattare il file Excel e salvarlo")
End Sub
Function NextR(xxSh, xxCol) As Long
Dim myN As Long
On Error Resume Next
myN = xxSh.Cells(10000, xxCol).End(-4162).Row
On Error GoTo 0
NextR = myN + 1
End Function
Mettila in un file word vuoto:
-dal file word, premi Alt-F11 per aprire l'editor delle macro
-seleziona il documento corrente nel frame di sinistra intitolato Progetto - Project
-Menu /Inserisci /Modulo
-copia il codice e incollalo nel frame vuoto del modulo appena inserito.
-chiudi e torna al documento Word
-eventualmente scrivi nel documento le istruzioni di uso.
-salvare il file in formato ".xlsm"
Istruzioni d'uso:
-chiudere eventuali sessioni Excel al momento aperte (non e' obbligatorio, la macro crea comunque una sua sessione di Excel in cui crea e compila un nuovo file Excel)
-aprire il documento da "sintetizzare" e lasciarlo attivo
-avviare la macro WordSummary: premere Alt-F8, selezionare WordSummary dall'elenco di macro disponibili, premere Esegui.
-un messaggio informera' del completamento dell'operazione
-attivare il documento Excel, formattare le celle a piacere; controllare l'esito confrontando a campione col file Word; salvare il file Excel e chiudere il file Word sintetizzato.
Fai sapere...
Registrazione
