Trasferire dati da foglio Excel in una tabella di Word

Nei vari forum che ho frequentato mi è capitato spesso di trovarmi a rispondere a questa domanda:

Avrei bisogno di trasferire i dati che si trovano su di un foglio di Excel, in una tabella di Word a prescindere dal numero di righe che la tabella di Excel ha..

Quindi, avendo un foglio di Excel con dei Record, bisogna trasferire questi  Record in una tabella di Word, per poterli stampare o quantomeno salvarli in formato pdf. Per poter effettuare questa operazione e risolvere il problema per prima cosa dobbiamo creare un file Word che contiene una Tabella, formata Esclusivamente da UNA riga e da tante colonne quanto sono le colonne del file di Excel che vogliamo trasferire, dopo aver creato un file di Word  avremmo una situazione del genere:

Rinominiamo il file, nel nostro esempio”ProvaTrasferimentoTabellaWord” e lo salviamo in una dir,in questo esempio che stiamo facendo,sia il file di Excel da dove poi lanceremo il codice che il file di Word che abbiamo salvato , debbono  trovarsi nella stessa Dir, pena il mal funzionamento.

Apriamo il file di Excel che contiene i dati da trasferire,il file avra una struttura come questa:

Una volta creati i file, dobbiamo inserire il codice  che ci permette di trasferire i record dal file di Excel al nostro file di Word.

Per il momento dimentichiamo del file di Word, perché tutto il codice che andremo ad inserire lo inseriremo nel file di Excel.

Apriamo l’Editor di VBA di Excel(Ctrl+F11), inseriamo un Modulo e incolliamo il codice riportato:

 Option Explicit
    Dim Word As Word.Application
    Dim DOC As Word.Document
Public Sub ProvatabellaWord()
    Dim tbl As Table
    Dim s As String
    Dim primaCella As String, cellValue As String
    Dim nomef As String, nomefile As String, nomefileb As String
    Dim sPath As String
    Dim myws As Worksheet
    Dim r As Long, c As Long
    Dim newrow As Object
    Dim v As String
    
    primaCella = "Nome"
    sPath = ThisWorkbook.Path & "\"
    Set myws = ActiveSheet
    Set Word = CreateObject("Word.Application")
    Word.Visible = True
    Set DOC = Word.Documents.Open(sPath & "ProvaTrasferimentoTabellaWord.docx")
    With DOC
        r = 1
        For Each tbl In Word.ActiveDocument.Tables
            s = tbl.Rows(1).Cells(1).Range.Text
            If InStr(1, s, primaCella) Then
                v = myws.Cells(r, 1).Value
                While v <> ""
                    If v = primaCella Then
                        r = r + 1
                        c = 1
                        Do While myws.Cells(r, c).Text <> ""
                            tbl.Rows.Add
                            Set newrow = tbl.Rows(tbl.Rows.Count)
                            Do While myws.Cells(r, c).Text <> ""
                                cellValue = myws.Cells(r, c).Text
                                newrow.Cells(c).Range.Text = cellValue
                                With newrow.Range.Font
                                    .Italic = True
                                    .Bold = False
                                    .Name = "Arial"
                                    .Size = 12

                                End With
                                c = c + 1
                            Loop
                            r = r + 1
                            c = 1
                        Loop
                    End If
                    r = r + 1
                    v = myws.Cells(r, 1).Value
                Wend
            End If
            nomefile = tbl.Rows(2).Cells(1).Range.Text
            nomefileb = Len(nomefile)
            '            nomef = Left(nomefile, (nomefileb - 2))
        Next tbl
        nomef = InputBox("inserisci il nome ", 1)
        If (nomef = "" And vbOK) Then
            nomef = Left(nomefile, (nomefileb - 2))
        End If
        If Dir(sPath & nomef & ".docx") <> "" Then
            Kill (sPath & nomef & ".docx")
        End If
        .SaveAs (sPath & nomef & ".docx")
        .Close
    End With
    Word.Quit
    Set DOC = Nothing
    Set Word = Nothing
End Sub