XL 2010 Publipostage étiquettes sur excel

L

Lolote83

XLDnaute Barbatruc

• 12 Juillet 2016

• #2

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

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

 

Vote positif 0 Vote négatif

C

Caillou

XLDnaute Impliqué

• 12 Juillet 2016

• #3

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

 

Vote positif 0 Vote négatif

B

bonoboas

XLDnaute Occasionnel

• 12 Juillet 2016

• #4

Merci

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 12 Juillet 2016

• #5

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 !!!!!

Cliquez pour agrandir...

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

 

Vote positif 0 Vote négatif

B

bonoboas

XLDnaute Occasionnel

• 12 Juillet 2016

• #6

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

 

Vote positif 0 Vote négatif

C

Caillou

XLDnaute Impliqué

• 12 Juillet 2016

• #7

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

 

Vote positif 0 Vote négatif

B

bonoboas

XLDnaute Occasionnel

• 12 Juillet 2016

• #8

Merci caillou.

 

Vote positif 0 Vote négatif