XL 2010 Publipostage étiquettes sur excel

[bonoboas]

Bonjour à tous,

J'ai créé un publipostage sur Excel pour imprimer des étiquettes en partant d'une base de données.
Ca fonctionne bien, mais j'aimerais qu'on me corrige et si possible que l'on m'aide à simplifie la manipe.
Ci-joint le fichier merci.

 

[Lolote83]

Salut BONOBOAS,
Pas grand chose a redire sur le code puisqu'il fonctionne.
Juste une petite chose pour éviter le "tressautement" lors du déplacement des données via COPIER-COLLER
Rajoute donc en début de code : Application.ScreenUpdating = False
Puis avant le End Sub : Application.ScreenUpdating = True
De plus, afin d'éviter de parcourir les 400 lignes, on teste la dernières ligne et du coup on ne parcours que les lignes utiles
Voici donc une partie du code

Sub Macro4()
    Application.ScreenUpdating = False               'Ligne rajoutée
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveCell.FormulaR1C1 = _
....
....
....
 
  Dim i As Integer
  xDerlig = Range("A65000").End(xlUp).Row   'Ligne rajoutée
  For i = 1 To xDerlig  '400
  'si i impair
  If i Mod 2 <> 0 Then
  Cells(i + 1, 1).Select
  Selection.Copy
  Cells(i, 2).Select
  ActiveSheet.Paste
  End If
  Next i
  Range("B2:B65000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  Range("A1").Select
  Application.ScreenUpdating = False            'Ligne rajoutée
End Sub

@+ Lolote83

 

[Caillou]

Bonjour,

Visiblement ta macro commence à traiter les données à partir de la ligne 6
Il faudrait remplacer 'BDD brut étiquettes'!R[5]C[12] par 'BDD brut étiquettes'!R[2]C[12]

De plus à la fin tu copies les lignes paires dans la colonne B de la ligne précédente pour ensuite supprimer les lignes pour lesquelles la colonne B est vide : ce qui a pour effet de supprimer la dernière étiquette si elle se retrouve seule !!!!!

Caillou

 

[bonoboas]

Merci

 

[Lolote83]

Salut Caillou,

De plus à la fin tu copies les lignes paires dans la colonne B de la ligne précédente pour ensuite supprimer les lignes pour lesquelles la colonne B est vide : ce qui a pour effet de supprimer la dernière étiquette si elle se retrouve seule !!!!!

Bien vu, cela m'avait echappé
@+ Lolote83

 

[bonoboas]

Merci lolote83 et merci caillou en effet la dernière ligne et supprimer il faut remplace la copie par un cut et supprimer les lignes vide de la colonne A. Et voilà. Merci à vous

 

[Caillou]

Re,

Voici un code qui se suffit à lui-même (ne necessite pas de formules dans Excel)
J'ai traité également le "et" pour le dernier prénom.
Sub etiq()
Dim bi As Integer 'N° ligne bdd
Dim enfants As String
Dim Adr1 As String, Adr2 As String, Adr3 As String
Dim ei As Integer, ej As Byte

bi = 2
ei = 1
ej = 1

Worksheets.Add
With Columns("A:B").EntireColumn
.ColumnWidth = 49
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 6
End With

With Sheets("BDD brut étiquettes")
Do Until .Cells(bi, "E") = ""
Adr1 = UCase(.Cells(bi, "D")) & " " & .Cells(bi, "E")
Adr2 = .Cells(bi, "A")
Adr3 = .Cells(bi, "B") & " " & .Cells(bi, "C")
Do While .Cells(bi + 1, "D") = "" And .Cells(bi + 1, "E") <> ""
If .Cells(bi + 2, "E") <> "" And .Cells(bi + 2, "D") = "" Then
Adr1 = Adr1 & ", " & .Cells(bi + 1, "E")
Else
Adr1 = Adr1 & " et " & .Cells(bi + 1, "E")
End If
bi = bi + 1
Loop
Cells(ei, ej) = Adr1 & vbCrLf & Adr2 & vbCrLf & Adr3
ej = ej + 1
If ej = 3 Then
ej = 1
ei = ei + 1
End If
bi = bi + 1
Loop
End With

Rows("1:" & ei).RowHeight = 113.5
End Sub

Caillou

 

[bonoboas]

Merci caillou.