Trasferire dati da un file di Word in un file di Excel con codice VBA.

Question

Buongiorno a tutti.

Come avviene da ormai parecchi anni, desidero il vostro professionale e competente aiuto su una procedura di importazione dei dati da un file di Word (ottenuto trasformando in WORD  un PDF con Adobe Acrobat Reader) in un file di Excel mantenendo la stessa formattazione ed intestazioni di colonne del file di Word.

Devo prepararmi ad un concorso pubblico nei Carabinieri e vorrei poter fare questa operazione con VBA per Excel.

Ho provato ad adattare un codice che tempo fa l'amico Norman (che ringrazio tantissimo) mi ha postato per una operazione simile, ma la formattazione dei dati era diversa da questa e non riesco ad importare i dati nel file di Excel, mi aiutate acapire cosa non va oppure come addattarlo alla mia nuova esigenza?

Sub ImportWordToExcel()

 ' VBA variables

Dim intFile As Integer

Dim lngNextRow As Long

Dim varFiles As Variant

' Word objects

' Use Tools->References... to

' include a reference to the

' Microsoft Word Object Library

Dim objWord As Word.Application

Dim objDocument As Word.Document

Dim strPath As String

' Excel objects

Dim Rng As Excel.Range

Dim WB As Excel.Workbook

Dim ws As Excel.Worksheet

Dim count As Long

' Clear our work area

 Application.ScreenUpdating = False

Set WB = Application.ActiveWorkbook

Set ws = ActiveWorkbook.ActiveSheet

'ws.Rows("2:100000").ClearContents

ws.UsedRange.Offset(1).ClearContents

' Get the list of Word files

varFiles = Application.GetOpenFilename("Word files (*.doc*),*.doc*", Title:="Seleziona i Files da copiare e importare.", MultiSelect:=True)

' Quit if none selected

If TypeName(varFiles) = "Boolean" Then

  Exit Sub ' Cancelled

Else

  ' Start a Word instance

  Set objWord = CreateObject("Word.Application")

  'objWord.Visible = True

   objWord.Visible = False

   objWord.DisplayAlerts = wdAlertsNone

  ' for each file...

  For intFile = LBound(varFiles) To UBound(varFiles)

    count = count + 1

Application.StatusBar = "Sto lavorando il file nr: " & count & " chiamato: " & strPath

  DoEvents

     ' open the document

     Set objDocument = objWord.Documents.Open(varFiles(intFile))

           strPath = objDocument.Name

           objDocument.Content.Copy

          WB.Sheets("Foglio1").Select

          ' Find the next row of data

          lngNextRow = Range("A100000").End(xlUp).Row + 1

          Range("A" & lngNextRow).Select

          WB.Sheets("Foglio1").PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True

        'End If

     ' End If

    'End If

    'objDocument.Close savechanges:=wdDoNotSaveChanges

    'Set objDocument = Nothing

  'Next

DoEvents

             Application.Wait (Now + TimeValue("0:00:10"))

             objDocument.Close savechanges:=wdDoNotSaveChanges

             DoEvents

             Set objDocument = Nothing

             DoEvents

         Next intFile

  objWord.Quit

  Set objWord = Nothing

End If

 Set ws = Nothing

Set WB = Nothing

MsgBox " Ho terminato la copia dei dati con successo!" & _

 Chr(13) & Chr(13) & "Sono stati importati " & count & " files complessivamente!", vbInformation, "WORD TO EXCEL"

Application.ScreenUpdating = True

 End Sub

I file di word che devo importare sono tanti e le  domande dovrebbero incollarsi in successione nelle righe del file di Excel, spero di essere stato chiaro.

Inoltre , per favore, aiutatemi ad affiancare alle domande anche la colonna delle risposte esatte riportate nell'ultima pagina del file di Word che allego.

Ringrazio tantissimo chi mi aiuta in questo.

Posto il file di Word al seguente link:

https://1drv.ms/w/s!Ali6qqOH3dOAjhwNfee_PzBj7l_X

Answer 1

Ciao Nicola,

Cit: Fammi sapere anche se l'allineamento errato della colonna delle risposte è l'unico problema che hai riscontrato.

Si Norman, questo è l'unico problema che ho incontrato su un **numero limitato ( sulla maggior parte funziona benissimo cambiando ogni volta il range dei dati e delle risposte giuste)**di file di Word mentre sul file chiamato: Ragionamento numerico (formattato come da immagine non da alcun risultato, ma no ho alcun messaggio di errore dal tuo codice).

Dato che la maggior parte dei file funzionano benissimo con il tuo codice, posto qui :

https://1drv.ms/f/s!Ali6qqOH3dOAjh_EDSD4CuLlspLm

i file di Word da sistemare e che non danno il risultato sperato.

Ho scaricato i tuoi due file.

Il secondo file illustra due caratteristiche particolarmente problematiche che sono state introdotte come risultato della conversione da Adobe del file PDF originale in un documento Word, ossia:

• Sporadicamente e casualmente, il documento di Word manca un carattere di interruzione di paragrafo alla fine di determinate righe. Ad esempio, nota la fine della riga evidenziata in blu:

Sfortunatamente, le interruzioni di paragrafo mancanti causano l'aggiunta delle righe pertinenti alla riga successiva e, di conseguenza, c'è una disparità tra l'elenco di domande e l'elenco di risposte corrispondente.

• Sporadicamente, nel caso di alcune pagine, la conversione in PDF di Adobe ha sovrapposto una riga di dati su una parte del piè di pagina, come si vede nel seguente screenshot:

• Sfortunatamente, quando il documento Word viene importato in Excel, i dati di sovrapposizione vengono persi.

Pertanto, ho modificato il codice di Word per inserire le interruzioni di paragrafo qualora fossero mancanti ed ho adattato il mio codice per riportare le risposte sempre sulle righe corrette. Inoltre, nel caso dei problemi relativi alla sovrapposizione di dati su alcuni piè di pagina, ho inserito una riga nella posizione richiesta delle domande, ho inserito il numero della domanda nella colonna A e, mediante un messagio alla conclusione del codice, Ho elencato le poche domande mancanti iin modo che tu potresti inserirle a mano.

Quindi, nel caso del file Capacit_ verbale.docx, il codice reporta tutte le domande con le richieste risposte e, per il secondo file, Ragionamento numerico.docx, il codice divide le righe coalescenti e elenca le domande mancanti dovuto ai problemi di sovrapposizione:

   

Quindi, sostituisci tutto il codice precedente con la seguente versione:

'=========>>

Option Explicit

Dim objWord As Word.Application

Dim WB As Workbook

Dim srcSH As Worksheet

Dim sFileName As String

Dim jCtr As Long

Dim arrMissing() As Variant

Const sFoglio As String = "Foglio1"          '<<=== Modifica

'--------->>

Public Sub Tester()

    Dim destSH As Worksheet

    Dim rngDomande As Range, rngRisposte As Range

    Dim arrIn As Variant, arrOut As Variant, arrOut2 As Variant

    Dim arrRisposte As Variant

    Dim sStr As String, sMsg As String, sTitle As String

    Dim iButtons As Long

    Const sIntervalloDomande As String = _

                                                  "A3:I1194"       '<<=== Modifica

    Const sIntervalloRisposte As String = _

                                                "A1200:I1291"      '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio)

        Set destSH = .Sheets.Add(After:=srcSH)

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With srcSH

        .Columns(1).Resize(5000).NumberFormat = "@"

        Set rngDomande = .Range(sIntervalloDomande)

        Set rngRisposte = .Range(sIntervalloRisposte)

    End With

    arrIn = rngDomande.Value

    arrIn = JoinRows(arrIn)

    arrIn = Compact_Columns(arrIn)

    arrIn = Compact_Rows(arrIn)

    arrOut = DeleteEmptyRows(arrIn)

    arrOut = AddMissingQuestionRows(arrOut)

    arrRisposte = rngRisposte.Value

    arrRisposte = Riordina_ModificaRisposte(arrRisposte)

    With destSH

        .Range("A2").Resize(UBound(arrOut), 6).Value = arrOut

        With .Range("A1").Offset(, 7). _

             Resize(UBound(arrRisposte))

            .NumberFormat = "@"

            .Value = arrRisposte

        End With

        If Not sFileName = vbNullString Then

            If Not SheetExists(sFileName) Then

                .Name = sFileName

            Else

                Application.DisplayAlerts = False

                WB.Sheets(sFileName).Delete

                Application.DisplayAlerts = True

                .Name = sFileName

            End If

        End If

    End With

    Call Format_Sheet(destSH)

    If IsArrayAllocated(arrMissing) Then

        sStr = Join(arrMissing, vbNewLine)

        sMsg = "Le seguente domande non sono state " _

               & "importate da Word." _

               & vbNewLine & vbNewLine _

               & "Controlla i piè di pagina pertinenti del " _

               & "documento Word ed " _

               & "inseririsci le domande mancanti a mano!" _

               & vbNewLine & vbNewLine _

               & sStr

        sTitle = "CONTROLLA DOMANDE MANCANTI!"

        iButtons = vbCritical

    Else

        sMsg = "Finito!"

        sTitle = "REPORT"

        iButtons = vbInformation

    End If

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:=sTitle)

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Sub ImportWordToExcel()

    Dim objDocument As Word.Document

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim varFiles As Variant

    Dim strPath As String

    Dim iFile As Long

    Dim iNextRow As Long

    Dim iCtr As Long

    Application.ScreenUpdating = False

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        .Cells.ClearContents

        Intersect(.Columns("B:I"), .Rows("1:5000")).NumberFormat = "@"

        .DrawingObjects.Delete

        .Cells(1, 1).Resize(3000).NumberFormat = "General"

    End With

    varFiles = Application.GetOpenFilename( _

               "Word files (*.doc*),*.doc*", _

               Title:="Seleziona i Files da copiare e importare.", _

               MultiSelect:=True)

    If TypeName(varFiles) = "Boolean" Then

        Call MsgBox( _

             Prompt:="Non hai selezionato un file Word da sviluppare", _

             Buttons:=vbCritical, _

             Title:="REPORT")

        GoTo XIT

    End If

    Set objWord = New Word.Application

    With objWord

        .Visible = False

        .DisplayAlerts = wdAlertsNone

        .Options.CheckSpellingAsYouType = False

        For iFile = LBound(varFiles) To UBound(varFiles)

            iCtr = iCtr + 1

            Application.StatusBar = "Sto lavorando il file nr: " _

                                    & iCtr & " chiamato: " _

                                    & strPath

            DoEvents

            Set objDocument = objWord.Documents.Open _

                              (varFiles(iFile))

            With objDocument

                strPath = .Name

                sFileName = Split(strPath, ".")(0)

                .SpellingChecked = True

                Call BreakLines

                .Content.Copy

                With WB.Sheets("Foglio1")

                    .Activate

                    iNextRow = .Range("A100000").End(xlUp).Row + 1

                    .Range("A" & iNextRow).Select

                    .PasteSpecial Format:="HTML", _

                                  Link:=False, _

                                  DisplayAsIcon:=False, _

                                  NoHTMLFormatting:=True

                End With

                DoEvents

                Application.Wait (Now + TimeValue("0:00:10"))

                objDocument.Close Savechanges:=wdDoNotSaveChanges

                DoEvents

                Set objDocument = Nothing

                DoEvents

            End With

        Next iFile

        .Quit

    End With

    Set objWord = Nothing

    Call MsgBox( _

         Prompt:="Ho terminato la copia dei dati con successo!" & _

                 vbNewLine & vbNewLine _

                 & "Sono stati importati " & iCtr _

                 & " files complessivamente!", _

         Buttons:=vbInformation, _

         Title:="WORD A EXCEL")

XIT:

    With Application

        .StatusBar = False

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Sub BreakLines()

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With objWord

        objWord.Selection.HomeKey unit:=wdStory

        Do

            .Selection.EndKey unit:=wdLine

            If .Selection.End >= .ActiveDocument.Content.End - 1 Then

                Exit Do

            End If

            If Asc(.Selection) <> 13 Then

                .Selection.InsertParagraphAfter

            End If

            .Selection.MoveDown unit:=wdLine

        Loop

    End With

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function JoinRows(Arr As Variant)

    Dim arrJoin() As Variant

    Dim vVal As Variant

    Dim aStr As String, sStr As String

    Dim i As Long, j As Long, k As Long

    Dim iDomanda As Long

    For i = 2 To UBound(Arr, 2) - 1

        For j = 2 To UBound(Arr) - 1

            k = 0

            vVal = Arr(j, 1)

            If IsNumeric(vVal) And Not IsEmpty(vVal) Then

                If vVal <= 356 Then

                    iDomanda = vVal

                    Do Until Arr(j + k, 1) > iDomanda

                        k = k + 1

                        sStr = Trim(Arr(j + k - 1, i))

                        Arr(j + k - 1, i) = Empty

                        ReDim Preserve arrJoin(1 To k)

                        arrJoin(k) = Trim(sStr)

                    Loop

                    aStr = Application.Trim(Join(arrJoin))

                    If aStr = vbNullString Then

                        Arr(j, i) = Empty

                    Else

                        Arr(j, i) = Application.Trim(Join(arrJoin))

                    End If

                    Erase arrJoin

                    j = j + k - 1

                End If

            End If

        Next j

    Next i

    JoinRows = Arr

End Function

'--------->>

Public Function Compact_Columns(Arr As Variant) As Variant

    Dim i As Long, j As Long, k As Long

    Dim bHeaderRow As Boolean

    bHeaderRow = True

    For i = 1 To UBound(Arr)

        For j = 2 To UBound(Arr, 2)

            If IsEmpty(Arr(i, j)) Then

                For k = j + 1 To UBound(Arr, 2)

                    If Not IsEmpty(Arr(i, k)) Then

                        Arr(i, j) = Arr(i, k)

                        Arr(i, k) = Empty

                        Exit For

                    End If

                Next k

            End If

        Next j

    Next i

    Compact_Columns = Arr

End Function

'--------->>

Public Function Compact_Rows(Arr As Variant) As Variant

    Dim i As Long, j As Long, k As Long

    Dim bHeaderRow As Boolean

    bHeaderRow = True

    For i = 1 To UBound(Arr)

        For j = 2 To UBound(Arr, 2)

            If IsEmpty(Arr(i, j)) Or bHeaderRow Then

                For k = j + 1 To UBound(Arr, 2)

                    If Not IsEmpty(Arr(i, k)) Then

                        Arr(i, j) = Arr(i, k)

                        Arr(i, k) = Empty

                        Exit For

                    End If

                Next k

            End If

        Next j

        bHeaderRow = False

    Next i

    Compact_Rows = Arr

End Function

'--------->

Public Function DeleteEmptyRows(Arr)

    Dim arrOut As Variant

    Dim i As Long, j As Long

    Dim bHeaderRow As Boolean

    ReDim arrOut(1 To UBound(Arr), 1 To 6)

    bHeaderRow = True

    jCtr = 0

    For i = 1 To UBound(Arr)

        If Application.IsNumber(Arr(i, 1)) Or bHeaderRow Then

            jCtr = jCtr + 1

            For j = 1 To 6

                arrOut(jCtr, j) = Arr(i, j)

            Next j

        End If

        bHeaderRow = False

    Next i

    DeleteEmptyRows = arrOut

End Function

'--------->

Public Function AddMissingQuestionRows(Arr)

    Dim arrOut As Variant

    Dim i As Long, j As Long

    Dim iCtr As Long, jCtr As Long

    Dim iUltimaDomanda As Long

    Dim UB As Long, UB2 As Long

    UB = UBound(Arr)

    UB2 = UBound(Arr, 2)

    With Application

        iUltimaDomanda = .Max(.Index(Arr, 0, 1))

    End With

    ReDim arrOut(1 To iUltimaDomanda, 1 To UB2)

    For i = 2 To iUltimaDomanda + 1

        iCtr = iCtr + 1

        For j = 1 To UB2

            arrOut(iCtr, j) = Arr(i, j)

        Next j

        If iCtr < iUltimaDomanda Then

            If Arr(i + 1, 1) <> Arr(i, 1) + 1 Then

                '\ Salta riga

                iCtr = iCtr + 1

                arrOut(iCtr, 1) = iCtr

                '\ Carica arrMissing con il numero della

                '\ domanda non riportata da Word

                jCtr = jCtr + 1

                ReDim Preserve arrMissing(1 To jCtr)

                arrMissing(jCtr) = iCtr

            End If

        End If

        If iCtr = iUltimaDomanda Then

            Exit For

        End If

    Next i

XIT:

    AddMissingQuestionRows = arrOut

End Function

'--------->>

Public Function Riordina_ModificaRisposte(Arr As Variant) As Variant

    Dim arrOut As Variant

    Dim i As Long, j As Long, k As Long

    Dim vVal As Variant

    Dim iHour As Long

    Dim UB As Long, UB2 As Long

    UB = UBound(Arr)

    UB2 = UBound(Arr, 2)

    ReDim arrOut(1 To UB * UB2 + 1, 1 To 1)

    arrOut(1, 1) = "Risposta Giusta"

    k = 1

    For i = 1 To UB2

        For j = 1 To UB

            vVal = Arr(j, i)

            If Not IsEmpty(vVal) Then

                k = k + 1

                If Not IsEmpty(vVal) And IsNumeric(vVal) Then

                    iHour = Hour(vVal)

                    vVal = "'" & iHour & "   A"

                End If

                arrOut(k, 1) = vVal

            End If

        Next j

    Next i

    Riordina_ModificaRisposte = arrOut

End Function

'--------->>

Public Sub Format_Sheet(aSH As Worksheet)

    Dim arrColWidths As Variant

    Dim arrHeaders As Variant

    Dim i As Long

    Const sColWidths As String = "8,54,30,30,30,30,4,12"

    Const sHeaders As String = "N.,Domanda,A,B,C,D"

    arrColWidths = Split(sColWidths, ",")

    arrHeaders = Split(sHeaders, ",")

    With aSH

        For i = 1 To UBound(arrColWidths) + 1

            .Columns(i).ColumnWidth = arrColWidths(i - 1)

        Next i

        .Range("A1").Resize(1, UBound(arrHeaders) + 1).Value = _

        arrHeaders

        With .UsedRange

            .WrapText = True

            .VerticalAlignment = xlCenter

            .IndentLevel = 2

            .EntireRow.AutoFit

        End With

    End With

End Sub

'--------->>

Function IsArrayAllocated(Arr As Variant) As Boolean

    On Error Resume Next

    IsArrayAllocated = IsArray(Arr) And _

                       Not IsError(LBound(Arr, 1)) And _

                       LBound(Arr, 1) <= UBound(Arr, 1)

End Function

'--------->>

Public Function SheetExists(sSheetName As String, _

                            Optional ByVal WB As Workbook) As Boolean

    On Error Resume Next

    If WB Is Nothing Then

        Set WB = ThisWorkbook

    End If

    SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

    On Error GoTo 0

End Function

'<<=========

===

Regards,

Norman

Answer 2

Ciao Norman, infatti sto avendo problemi di importazione dei dati in Excel, il tuo codice funziona benissimo con il primo file di Word postato,  con gli altri ( come tu giustamente affermi qui:

**Non posso essere certo che il codice funzionerà perfettamente su tutti i tuoi file Word in quanto la formatazzione e la disposizione dei loro dati dipenderanno dall'algoritmo utilizzato da Adobe per convertire i tuoi file PDF in file Word. Nota, inoltre, che non esista un algorimo perfetto per questo compito e quello di Adobe non fa più chetentare di rendere possibile la visualizzazione dei dati, senza rispetare l'integrità di frase o righe di testo. )**non va il codice va in errore.

Come faccio, aiutami tu, magari ti posso inviare personalmente tutti i file PDF del concorso per vedere come intraprendere il miglior modo dell'importazione di dati in Excel, proprio perché con Excel vorrei poi successivamente esercitarmi allo svolgimento dei quiz.

I file PDF dei quiz dei carabinieri sono molti e di materie varie.

Attendo tue notizie, grazie come sempre per il tuo preziosissimo aiuto e la tua immensa pazienza.

Ciao Nicola.

P.S. penso che One Drive non mi permetta di allegare tanti file pdf , oppure no?

Answer 3

Ciao Nicola,

Ciao Norman, buongiorno, scusami per il ritardo della risposta.

Sto facendo le prove su tutti i files di Word da importare in Excel.

Per ora su di un file solo il tuo codice funziona perfettamente, aspetto solo di provarlo su tutti i files di Word da lavorare e se ci dovessero essere dei problemi te li segnalo.

Grazie al tuo ( vostro ) aiuto sono riuscito sempre a risolvere qualsiasi problematica ed esigenza in Excel. 

Non ci abbandonate mai, sarebbe un vero problema per tutti noi utenti alle prime armi.

Non posso essere certo che il codice funzionerà perfettamente su tutti i tuoi file Word in quanto la formatazzione e la disposizione dei loro dati dipenderanno dall'algoritmo utilizzato da Adobe per convertire i tuoi file PDF in file Word. Nota, inoltre, che non esista un algorimo perfetto per questo compito e quello di Adobe non fa più che tentare di rendere possibile la visualizzazione dei dati, senza rispetare l'integrità di frase o righe di testo. 

A questo proposito, controllando il tuo file Word, si vede, ad esempio, che ogni lunga frase si dispone su più righe.

Comunque, a questo punto, vorrei mettere in questione un approccio che:

• Crea un file Word da un file Excel
• Crea, con codice,  più file PDF dai file di Word o Excel
• Transforma dei file PDF in file Word
• Esporta, con codice, i file Word (che ora mancano l'integità del testo originale) in file Excel
• Utilizza un complesso codice in Excel per rettificare i problemi dell'algoritmo di traduzione di Adobe e rendere coerente i dati e per ristabilire la disposizione dei dati i quali, molto tempo fà, hanno iniziato la vita in Excel - o, forse, ancora prima, in Word!

Se io volessi intraprendere un progetto di concorso a quiz simile, penso che vorrei eseguire il lavoro sempre da Word (o Excel), sfruttando la funzionalità di più programmi della famiglia Office. Se volessi distrubuire i risultati in documenti PDF, il lo farei solo alla conclusione di tutto del lavoro di preparazione.

Detto questo, i miei commenti non sono minimamente intesi come una critica ai tuoi sforzi: hai manifestamente lavorato molto diligentemente ed a lungo su un incarico difficile e complesso e, chiaramente, io non sono a conoscenza di nessuno dei fattori di fondo che potrebbero averti costretto a cambiare il tuo approccio in vari momenti durante l'incarico. Conosco fin troppo bene, e per esperienza amara, come le linee guida di un progetto possono essere cambiate improvvisamente e ripetutamente! (:-

===

Regards,

Norman

Answer 4

Ciao Norman, buongiorno, scusami per il ritardo della risposta.

Sto facendo le prove su tutti i files di Word da importare in Excel.

Per ora su di un file solo il tuo codice funziona perfettamente, aspetto solo di provarlo su tutti i files di Word da lavorare e se ci dovessero essere dei problemi te li segnalo.

Grazie al tuo ( vostro ) aiuto sono riuscito sempre a risolvere qualsiasi problematica ed esigenza in Excel. 

Non ci abbandonate mai, sarebbe un vero problema per tutti noi utenti alle prime armi.

A presto, ti acciorno appena finisco il mio lavoro su tutti i quiz.

Ciao Nicola.

Answer 5

Ciao Nicola,

Come avviene da ormai parecchi anni, desidero il vostro professionale e competente aiuto su una procedura di importazione dei dati da un file di Word (ottenuto trasformando in WORD  un PDF con Adobe Acrobat Reader) in un file di Excel mantenendo la stessa formattazione ed intestazioni di colonne del file di Word.

Devo prepararmi ad un concorso pubblico nei Carabinieri e vorrei poter fare questa operazione con VBA per Excel.

Ho provato ad adattare un codice che tempo fa l'amico Norman (che ringrazio tantissimo) mi ha postato per una operazione simile, ma la formattazione dei dati era diversa da questa e non riesco ad importare i dati nel file di Excel, mi aiutate acapire cosa non va oppure come addattarlo alla mia nuova esigenza?

Sub ImportWordToExcel()

 ' VBA variables

Dim intFile As Integer

Dim lngNextRow As Long

Dim varFiles As Variant

' Word objects

' Use Tools->References... to

' include a reference to the

' Microsoft Word Object Library

Dim objWord As Word.Application

Dim objDocument As Word.Document

Dim strPath As String

' Excel objects

Dim Rng As Excel.Range

Dim WB As Excel.Workbook

Dim ws As Excel.Worksheet

Dim count As Long

' Clear our work area

 Application.ScreenUpdating = False

Set WB = Application.ActiveWorkbook

Set ws = ActiveWorkbook.ActiveSheet

'ws.Rows("2:100000").ClearContents

ws.UsedRange.Offset(1).ClearContents

' Get the list of Word files

varFiles = Application.GetOpenFilename("Word files (*.doc*),*.doc*", Title:="Seleziona i Files da copiare e importare.", MultiSelect:=True)

' Quit if none selected

If TypeName(varFiles) = "Boolean" Then

  Exit Sub ' Cancelled

Else

  ' Start a Word instance

  Set objWord = CreateObject("Word.Application")

  'objWord.Visible = True

   

   objWord.Visible = False

   

   objWord.DisplayAlerts = wdAlertsNone

  ' for each file...

  For intFile = LBound(varFiles) To UBound(varFiles)

    count = count + 1

Application.StatusBar = "Sto lavorando il file nr: " & count & " chiamato: " & strPath

  

  DoEvents

   

     ' open the document

  

     Set objDocument = objWord.Documents.Open(varFiles(intFile))

         

           strPath = objDocument.Name

    

           objDocument.Content.Copy

          WB.Sheets("Foglio1").Select

          ' Find the next row of data

          lngNextRow = Range("A100000").End(xlUp).Row + 1

          Range("A" & lngNextRow).Select

          WB.Sheets("Foglio1").PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True

        'End If

     ' End If

      

    'End If

    'objDocument.Close savechanges:=wdDoNotSaveChanges

    'Set objDocument = Nothing

  'Next

DoEvents

             Application.Wait (Now + TimeValue("0:00:10"))

             objDocument.Close savechanges:=wdDoNotSaveChanges

             DoEvents

             Set objDocument = Nothing

             DoEvents

         Next intFile

  objWord.Quit

  Set objWord = Nothing

End If

 Set ws = Nothing

Set WB = Nothing

MsgBox " Ho terminato la copia dei dati con successo!" & _

 Chr(13) & Chr(13) & "Sono stati importati " & count & " files complessivamente!", vbInformation, "WORD TO EXCEL"

Application.ScreenUpdating = True

 End Sub

I file di word che devo importare sono tanti e le  domande dovrebbero incollarsi in successione nelle righe del file di Excel, spero di essere stato chiaro.

Inoltre , per favore, aiutatemi ad affiancare alle domande anche la colonna delle risposte esatte riportate nell'ultima pagina del file di Word che allego.

Ringrazio tantissimo chi mi aiuta in questo.

Posto il file di Word al seguente link: 

https://1drv.ms/w/s!Ali6qqOH3dOAjhwNfee_PzBj7l_X

Credo che i tuoi problemi principali siano dovuti alla conversione d'un file pdf in un documento Word.

Tuttavia, dopo aver eseguito la tua macro per importare i dati in Excel da Word, per rettificare la disposizione e il formato dei dati, prova qualcosa del genere:

'=========>>

Option Explicit

Dim jCtr As Long

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim rngDomande As Range, rngRisposte As Range

    Dim arrIn As Variant, arrOut As Variant

    Dim arrRisposte As Variant

    Const sFoglio As String = "Foglio1"               '<<=== Modifica

    Const sIntervalloDomande As String = _

                                                 "A3:I672"         '<<=== Modifica

    Const sIntervalloRisposte As String = _

                                              "A675:I714"        '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio)

        Set destSH = .Sheets.Add(After:=srcSH)

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With srcSH

        Set rngDomande = .Range(sIntervalloDomande)

        Set rngRisposte = .Range(sIntervalloRisposte)

    End With

    arrIn = rngDomande.Value

    arrIn = JoinRows(arrIn)

    arrIn = Compact_Columns(arrIn)

    arrIn = Compact_Rows(arrIn)

    arrOut = DeleteEmptyRows(arrIn)

    arrRisposte = rngRisposte.Value

    arrRisposte = Riordina_ModificaRisposte(arrRisposte)

    With destSH

        .Range("A1").Resize(jCtr, 6).Value = arrOut

        .Range("A1").Offset(, 7). _

                Resize(UBound(arrRisposte)).Value = arrRisposte

    End With

    Call Format_Sheet(destSH)

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function JoinRows(arr As Variant)

    Dim arrJoin() As Variant

    Dim vVal As Variant

    Dim aStr As String, sStr As String

    Dim i As Long, j As Long, k As Long

    Dim iDomanda As Long

    For i = 2 To UBound(arr, 2) - 1

        For j = 2 To UBound(arr) - 1

            k = 0

            vVal = arr(j, 1)

            If IsNumeric(vVal) And Not IsEmpty(vVal) Then

                If vVal <= 356 Then

                    iDomanda = vVal

                    If vVal = 356 Then Stop

                    Do Until arr(j + k, 1) > iDomanda

                        k = k + 1

                        sStr = Trim(arr(j + k - 1, i))

                        arr(j + k - 1, i) = Empty

                        ReDim Preserve arrJoin(1 To k)

                        arrJoin(k) = Trim(sStr)

                    Loop

                    aStr = Application.Trim(Join(arrJoin))

                    If aStr = vbNullString Then

                        arr(j, i) = Empty

                    Else

                        arr(j, i) = Application.Trim(Join(arrJoin))

                    End If

                    Erase arrJoin

                    j = j + k - 1

                End If

            End If

        Next j

    Next i

    JoinRows = arr

End Function

'--------->>

Public Function Compact_Columns(arr As Variant) As Variant

    Dim i As Long, j As Long, k As Long

    Dim bHeaderRow As Boolean

    bHeaderRow = True

    For i = 1 To UBound(arr)

        For j = 2 To UBound(arr, 2)

            If IsEmpty(arr(i, j)) Then

                For k = j + 1 To UBound(arr, 2)

                    If Not IsEmpty(arr(i, k)) Then

                        arr(i, j) = arr(i, k)

                        arr(i, k) = Empty

                        Exit For

                    End If

                Next k

            End If

        Next j

    Next i

    Compact_Columns = arr

End Function

'--------->>

Public Function Compact_Rows(arr As Variant) As Variant

    Dim i As Long, j As Long, k As Long

    Dim bHeaderRow As Boolean

    bHeaderRow = True

    For i = 1 To UBound(arr)

        For j = 2 To UBound(arr, 2)

            If IsEmpty(arr(i, j)) Or bHeaderRow Then

                For k = j + 1 To UBound(arr, 2)

                    If Not IsEmpty(arr(i, k)) Then

                        arr(i, j) = arr(i, k)

                        arr(i, k) = Empty

                        Exit For

                    End If

                Next k

            End If

        Next j

        bHeaderRow = False

    Next i

    Compact_Rows = arr

End Function

'--------->

Public Function DeleteEmptyRows(arr)

    Dim arrOut As Variant

    Dim i As Long, j As Long

    Dim bHeaderRow As Boolean

    ReDim arrOut(1 To UBound(arr), 1 To 6)

    bHeaderRow = True

    For i = 1 To UBound(arr)

        If Application.IsNumber(arr(i, 1)) Or bHeaderRow Then

            jCtr = jCtr + 1

            For j = 1 To 6

                arrOut(jCtr, j) = arr(i, j)

            Next j

        End If

        bHeaderRow = False

    Next i

    DeleteEmptyRows = arrOut

End Function

'--------->>

Public Function Riordina_ModificaRisposte(arr As Variant) As Variant

    Dim arrOut As Variant

    Dim i As Long, j As Long, k As Long

    Dim vVal As Variant

    Dim iHour As Long

    Dim UB As Long, UB2 As Long

    UB = UBound(arr)

    UB2 = UBound(arr, 2)

    ReDim arrOut(1 To UB * UB2 + 1, 1 To 1)

    arrOut(1, 1) = "Risposta Giusta"

    k = 1

    For i = 1 To UB2

        For j = 1 To UB

            k = k + 1

            vVal = arr(j, i)

            If Not IsEmpty(vVal) And IsNumeric(vVal) Then

                iHour = Hour(vVal)

                vVal = "'" & iHour & "   A"

            End If

            arrOut(k, 1) = vVal

        Next j

    Next i

    Riordina_ModificaRisposte = arrOut

End Function

'--------->>

Public Sub Format_Sheet(aSH As Worksheet)

    Dim arrColWidths As Variant

    Dim i As Long

    Const sColWidths As String = "8,54,30,30,30,30,4,12"

    arrColWidths = Split(sColWidths, ",")

    With aSH

        For i = 1 To UBound(arrColWidths) + 1

            .Columns(i).ColumnWidth = arrColWidths(i - 1)

        Next i

        With .UsedRange

            .WrapText = True

            .VerticalAlignment = xlCenter

            .IndentLevel = 2

            .EntireRow.AutoFit

        End With

    End With

End Sub

'<<=========

Postscriptum:

Inoltre , per favore, aiutatemi ad affiancare alle domande anche la colonna delle risposte esatte riportate nell'ultima pagina del file di Word che allego.

Rileggendo la tua domanda, credo che io abbia trascurato questa richiesta aggiuntiva!

Pertanto, oltre a chiedere scusa, ho sostituito il mio codice originale ed ho approfittato per apportare alcune modifiche aggiuntive.

===

Regards,

Norman