Publipostage à l'envers:

[stp74]

Publipostage à l'envers:recuperer du word dans excel
Je voudrai recuperer dans excel un fichier d'etiquette adresse word.
C Possible?

[nouv]

bonjour,

Ah ! non ! c'est un peu court, jeune homme !
On pouvait dire... Oh ! Dieu !.., bien des choses en somme...
En variant le ton, - par exemple, tenez
Agressif : " Moi, monsieur, si j'avais un tel fichier,
Il faudrait sur-le-champ que je vous l'envoyasse ! "
Amical : " Mais il doit trainer dans une place
Pour voir, cliquez-nous "envoyer" ou je zap ! "
Descriptif : " C'est un doc !... c'est une txt !... c'est un csv !
Que dis-je, c'est un csv ?... faisons appel au pendule ! "

.....

à +
><>

[Jiheme]

Bonjour STP, nouv

Sans rapport avec le fil :

Nouv très bien en plus d'Excel, on a des lettres, j'adore ta parodie et en plus,

A la fin de l'envoi tu touches.

A+

[stp74]

c un .doc
Vous avez besoin que je vous l'envoyasse?
Ne pouvez vous pas m'expliquer la procedure de recuperation
merci

[nouv]

re,

bon puisque ça plait :
Ô rage ! ô désespoir ! ô week end ennemi ! N'ai-je donc pas ce fichier honni ? Et ne puis-je envoyer ces étiquettes, et voir d'un seul coup répondre à ma requête ?

désolée mais boule en panne ce matin, donc j'irais au plus simple - copier coller

sans connaitre la structure du fichier word, difficile de répondre à ta question, donc oui ton fichier word serait le bienvenue ou alors un très très très bon descriptif du fichier...

><>

[stp74]

ci joint une partie de mon fichier

[tatiak]

B'soir à tous, (et pour mon 500 ième!!!)
Un premier jet d'une macro à placer dans un module à déclencher par un bouton placé sur une des feuilles.
A noter : le code est "générique", ç-à-d : pas besoin d'activer de référence à quelconque librairie (et toc!)

Option Explicit

Sub Etiquettes_Word()
Dim NDF As String
Dim WordApp As Object
Dim WordDoc As Object
Dim i As Integer, j As Integer
Dim LigneXL As Integer
    LigneXL = ActiveSheet.Range("A65000").End(xlUp).Row + 1
    NDF = Application.GetOpenFilename
    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
    With WordApp
        .Visible = False
        With WordDoc.Tables(1)
            For i = 1 To .Rows.Count
                For j = 1 To 3
                    ActiveSheet.Cells(LigneXL, 1).Value = .Cell(i, j).Range.Text
                    LigneXL = LigneXL + 1
                Next j
            Next i
        End With
    End With
    WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    MsgBox (" Acquisition Ok")
End Sub

Action de la macro : le contenu des étiquettes se copie à la file dans la colonne A de la feuille. (pas testé sur des étiquettes sur plusieurs pages : à voir ...)
Amélioration à apporter : le découpage propre des données par colonnes ...
tatiak

[tatiak]

Bonjour à tous,
Pour le 501ème, et en complément de la macro d'hier, une p'tite fonction qui tronçonne le contenu en Nom/Adresse/Cp/Ville

Option Explicit

Sub Etiquettes_Word()
Dim NDF As String
Dim WordApp As Object
Dim WordDoc As Object
Dim i As Integer, j As Integer
Dim LigneXL As Integer
Dim tatiak As String
    LigneXL = ActiveSheet.Range("A65000").End(xlUp).Row + 1
    NDF = Application.GetOpenFilename
    On Error Resume Next
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
    With WordApp
        .Visible = False
        With WordDoc.Tables(1)
            For i = 1 To .Rows.Count
                For j = 1 To 3
                    tatiak = .Cell(i, j).Range.Text
                    ActiveSheet.Cells(LigneXL, 1).Value = PartieLigne(1, tatiak)
                    ActiveSheet.Cells(LigneXL, 2).Value = PartieLigne(2, tatiak)
                    ActiveSheet.Cells(LigneXL, 3).Value = Mid(PartieLigne(3, tatiak), 1, 5)
                    ActiveSheet.Cells(LigneXL, 4).Value = Mid(PartieLigne(3, tatiak), 7)
                    LigneXL = LigneXL + 1
                Next j
            Next i
        End With
    End With
    WordApp.Application.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
    MsgBox (" Acquisition Ok")
End Sub

Function PartieLigne(N As Byte, S As String) As String
Dim Caract As String
Dim i As Integer, j As Integer, nb13  As Integer
    PartieLigne = ""
    i = 1
    nb13 = 0
    Caract = Mid(S, i, 1)
    Do
        Do
            Caract = Mid(S, i, 1)
            i = i + 1
        Loop Until Caract = Chr$(13)
        nb13 = nb13 + 1
    Loop Until nb13 = N
    j = i
    Do
        Caract = Mid(S, j, 1)
        j = j + 1
    Loop Until Caract = Chr$(13)
    PartieLigne = Mid(S, i + 1, j - i)
End Function

Et voilà, bon dimanche
tatiak
PS: je me permets juste une remarque, la mise en ligne d'un fichier nominatif avec adresses est p'têt pas très conseillé, un fichier "anonymisé" aurait p'têt été mieux (même si ça semble être une injonction paradoxale ... )

[stp74]

Titiak,
mon fichier word adresse comporte plusieurs centaines de pages .
comment faire pour traiter tout le fichier ,car la macro ne traite qu'une seule page.

Bravo et merci a Titiak pour son exellent travail

[tatiak]

Re
Merci pour le compliment
Pour un grand document, c'est simple, yaka modifier la macro comme suit :

        For NbTableaux = 1 To WordDoc.tables.Count
            With WordDoc.tables(NbTableaux)
                For i = 1 To .Rows.Count
                    For j = 1 To 3
                        tatiak = .Cell(i, j).Range.Text
                        ActiveSheet.Cells(LigneXL, 1).Value = PartieLigne(1, tatiak)
                        ActiveSheet.Cells(LigneXL, 2).Value = PartieLigne(2, tatiak)
                        ActiveSheet.Cells(LigneXL, 3).Value = Mid(PartieLigne(3, tatiak), 1, 5)
                        ActiveSheet.Cells(LigneXL, 4).Value = Mid(PartieLigne(3, tatiak), 7)
                        LigneXL = LigneXL + 1
                    Next j
                Next i
            End With
        Next NbTableaux

ce qui prend en compte l'ensemble des "tables" du doc word
tatiak

[stp74]

j'ai une erreur de compilation avec le script quand je le modifie comme ci dessous:

Option Explicit

Sub Etiquettes_Word()
Dim NDF As String
Dim WordApp As Object
Dim WordDoc As Object
Dim i As Integer, j As Integer
Dim LigneXL As Integer
Dim tatiak As String
LigneXL = ActiveSheet.Range("A65000").End(xlUp).Row + 1
NDF = Application.GetOpenFilename
On Error Resume Next
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
With WordApp
.Visible = False
For NbTableaux = 1 To WordDoc.tables.Count
With WordDoc.tables(1)
For i = 1 To .Rows.Count
For j = 1 To 3
tatiak = .Cell(i, j).Range.Text
ActiveSheet.Cells(LigneXL, 1).Value = PartieLigne(1, tatiak)
ActiveSheet.Cells(LigneXL, 2).Value = PartieLigne(2, tatiak)
ActiveSheet.Cells(LigneXL, 3).Value = Mid(PartieLigne(3, tatiak), 1, 5)
ActiveSheet.Cells(LigneXL, 4).Value = Mid(PartieLigne(3, tatiak), 7)
LigneXL = LigneXL + 1
Next j
Next i
End With
End With
Next NbTableaux
WordApp.Application.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
MsgBox (" Acquisition Ok")
End Sub

Function PartieLigne(N As Byte, S As String) As String
Dim Caract As String
Dim i As Integer, j As Integer, nb13 As Integer
PartieLigne = ""
i = 1
nb13 = 0
Caract = Mid(S, i, 1)
Do
Do
Caract = Mid(S, i, 1)
i = i + 1
Loop Until Caract = Chr$(13)
nb13 = nb13 + 1
Loop Until nb13 = N
j = i
Do
Caract = Mid(S, j, 1)
j = j + 1
Loop Until Caract = Chr$(13)
PartieLigne = Mid(S, i + 1, j - i)
End Function

[stp74]

je n'avais pas vu le nouveau fichier
tout fonctionne très bien
encore bravo et bon dimanche