Microsoft 365 Enlever les espaces dans une colonne pour impression code VBA

[dubarre]

Bonjour à tous

Je viens vers vous car j’ai une petite question à vous poser quand vous ouvrez le classeur vous

cliquez sur « consulter » > édition > « édition courante » > « planche d’étiquette » > « individuelle » et vous mettez au hasard un nom cliquez sur « valider » ensuite cliquez « planche d’étiquettes » ça vous emmène sur l’onglet "Planche_Imp_Indiv"

vous pouvez voir l’adresse en plusieurs fois au format pour les planche d'éttiquette autocollants que je souhaite par contre je voudrais que dans chaque partie d’adresse si il y a des espaces entre les lignes qu’elle se comble automatiquement

car plusieurs adresses n’ont pas le même nombre de lignes il y a des compléments d’adresse qu’il y a pas dans d’autres et ainsi de suite donc je voulais savoir comment j’aurais pu organiser ça s’il vous plaît en code VBA

j’ai voulu tester dans Word mais je n’arrive pas à comprendre comment cela fonctionne et en plus je voudrais importer l’adresse directement mais ça devient compliqué donc je pense que le plus simple c’est de le faire sur une page Excel que j’ai réussi à mettre en forme selon ma planche d’étiquettes personnalisée.

Toutes les idées son les bien venue s'il vous plaît.

 

[chris]

Bonjour

Dans Word le publipostage prévoit cela

 

[patricktoulon]

bonjour @dubarre tu a pensé à l’utilisation sur un excel 32 bits (non bien sur )
souhaitons que ça n'arrive pas alors

 

[patricktoulon]

re
ton module 5
ceci fonctionnera sur les deux

Option Explicit
'Code geschrieben von Daniel Klann
#If vb7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongLong, ByVal ncode As LongLong, ByVal wParam As LongLong, lParam As Any) As LongLong
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongLong
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongLong, ByVal lpfn As LongLong, ByVal hmod As LongLong, ByVal dwThreadId As LongLong) As LongLong
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongLong) As LongLong
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongLong, ByVal nIDDlgItem As LongLong, ByVal wMsg As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongLong, ByVal lpClassName As String, ByVal nMaxCount As LongLong) As LongLong
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongLong
Public Function NewProc(ByVal lngCode As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Private hHook As LongLong
#Else
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private hHook As Long
#End If
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Dim RetVal
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim strClassName As String, lngBuffer As LongLong
If lngCode < HC_ACTION Then
    NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
    Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then
    RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then
        SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
End If
CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As LongLong, lngThreadID As LongLong
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function

Sub MdpEntrer()

Dim Mdp As String

'Mdp = InputBoxDK("Entrer le mot de passe", "Demande")
'
'If Mdp <> "Apbp67120" Then
'MsgBox "Le mot de passe est incorrect", vbCritical
'Exit Sub
'ElseIf Mdp = "Apbp67120" Then

            Feuil1.Visible = True
            Feuil1.Activate
            Feuil2.Visible = xlSheetHidden
            Feuil3.Visible = xlSheetHidden
            Feuil5.Visible = xlSheetHidden
            Feuil6.Visible = xlSheetHidden
            Feuil8.Visible = xlSheetVeryHidden

        Feuil1.Range("A1:X52").Select
        ActiveWindow.Zoom = True
       Cells(1, 1).Select

'End If




End Sub

Sub MdpConsulter()

        Feuil5.Visible = True
        Feuil3.Visible = True
        Feuil5.Activate
        Feuil1.Visible = xlVeryHidden
        Feuil2.Visible = xlVeryHidden
       
With Feuil5.Cells
    .EntireColumn.Hidden = False
    .EntireRow.Hidden = False
    .Clear
    .Interior.ColorIndex = xlNone
    '.HorizontalAlignment = xlCenter
    '.VerticalAlignment = xlCenter
    '.ColumnWidth = 15
    '.RowHeight = 15
End With


       
Feuil5.Cells.Clear
ThisWorkbook.Sheets("BDD").Range("A1").CurrentRegion.Copy Sheets("Vue_listes_artistes").Range("A1")

    'Rows("1:2").Select
    'Range("A2").Activate
    'Selection.EntireRow.Hidden = True
UserForm9.Show

Range("A1").Select
    Selection.AutoFilter

End Sub

 

[patricktoulon]

re
ok j'ai regardé ton problème est simple tu a codé l'ecriture sur baseBDD(("Planche_Imp_Indiv")
EN DUR!!!
parti de là comme tout les artistes n'ont pas toutes les ligne remplies ben tu te retrouve avec des lignes vides

mon idée
tu crée un array avec les données (celles qui sont pleines)et dans une boucle tu les trafert dans baseBDD et a chaque tour de boucle donc étiquette suivante sur la planche tu saute une seule ligne

c'est simple non ?

à nouveau je le répète car ça devient pénible de vous filer un coup de main
""arrêter de faire des userform 4k!!"" ( )

 

[job75]

Bonjour,

@patricktoulon au post #4 tu as mis des PtrSafe pour les 2 cas !

A+

 

[patricktoulon]

bonjour @job75
oupss!! merci

faut dire que chez moi 2013 32bit ça moufte pas car j'ai vb7 et vb6
peut être devrais-je mettre "#if win 64 and vb7"

 

[patricktoulon]

re:
tiens vire TOUT!!!!!!!(interminable) ton evenement "CommandButton14_clicl()"
et met celui ci

Private Sub CommandButton14_Click()
    Dim baseDD As Worksheet, a&, TbL
    Unload Me
    Unload UserForm6
    Sheets("Planche_Imp_Indiv").Visible = True
    Set baseDD = Sheets("Planche_Imp_Indiv")
    '--------------------------------------------------------------
    'Impression étiquette colonnes 1 et 2
    '--------------------------------------------------------------
    texte = Me.CbxCivilite.Value & " " & Me.TextBox2.Value & " " & Me.TextBox24.Value & "," & Me.TextBox3.Value & "," & Me.TextBox4.Value & "," & Me.TextBox5.Value & "," & Me.TextBox6.Value & "," & Me.TextBox7.Value & "," & Me.TextBox9.Value & ","
    TbL = Application.Transpose(Split(Replace(Replace(texte, ",,,", ","), ",,", ","), ","))
    With baseDD
        For i = 1 To 7
              a = 8 * (i - 1) + 1    ' si on garde cette mise en page
            .Cells(a, 2).Resize(UBound(TbL)).Value = TbL
            .Cells(a, 1).Resize(UBound(TbL)).Value = TbL
        Next
        .PrintPreview
        .[A:B].ClearContents 'tu avais oublié
        .Visible = False
    End With
End Sub

tu avais oublié le clear
car quand tu imprime des étiquettes qui ont moins de données que les précédentes certaines données restaient bien évidemment (c'est ballo!!!)
met aussi [A:B] alignée a gauche!!!!(et oui le code postal est un numérique donc aligné a droite automatiquement ) c’était pas cohérent visuellement avec le texte qui lui est aligné a gauche

 

[dubarre]

Bonjour à tous merci de m'aider pour le problème je décide de prendre note de tout ce que vous m'avez dit je n'ai pas le temps aujourd'hui de faire des essais mais je vais essayer de faire ça ce week-end

J'ai juste eu le temps d'essayer ce que tu m'as proposé dans le poste quatre il me met un message d'erreur sur le #Else j'essaierai de voir ce week-end pourquoi il ne met ce problème encore une fois en vous remerciant de votre aide cordialement.

Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongLong, ByVal ncode As LongLong, ByVal wParam As LongLong, lParam As Any) As LongLong
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongLong
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongLong, ByVal lpfn As LongLong, ByVal hmod As LongLong, ByVal dwThreadId As LongLong) As LongLong
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongLong) As LongLong
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongLong, ByVal nIDDlgItem As LongLong, ByVal wMsg As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongLong, ByVal lpClassName As String, ByVal nMaxCount As LongLong) As LongLong
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongLong
Public Function NewProc(ByVal lngCode As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Private hHook As LongLong
#Else
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private hHook As Long

 

[dubarre]

Rebonjour juste pour répondre aux messages de Chris j'ai essayé de le faire sur Word mais je ne trouve pas de tutoriel qui permette d'expliquer pour un seul individu cela fonctionne pour le publipostage avec plusieurs données dont plusieurs adresses mais pour un seul individu je n'arrive pas à trouver si quelqu'un a un tutoriel à proposer sur le sujet je suis preneur aussi cordialement

 

[patricktoulon]

ton problème de lignes vides est réglé dans mon 2d post

 

[dubarre]

Bonjour à tous c'est vrai que concernant les lignes vide tu ma aider à réglait le problème par contre pour ma connaissance personnelle je voudrais essayer de trouver comment ça fonctionne sur Word s'il vous plaît

 

[dubarre]

Bonjour

Je viens de tester la proposition de @patricktoulon concernant les éditions étiquettes ça fonctionne correctement.

Par contre un peu plus haut vous proposez les rectifications sur le module 5
et comme vous pouvez voir sur la photo que je vous envoie j'ai un message d'erreur concernant "adresseoff" et la ce que vous proposez je n'ai pas encore tout compris je sais que c'est des déclarations mais je n'ai pas encore tout vu sur le fonctionnement

J'ai juste compris que cela à une interférence avec le mot de passe que je demande dans un inputbox sur le bouton "Mise à jour" je vous joins le classeur où j'ai testé le code en vous remerciant.

 

[patricktoulon]

bonjour @dubarre
ça c'est un userform en 4k
ceci est un cliché de mon écran complet (je vois pas le bas et le reste à droite )
j'ai été obligé de fermer excel par ctrl alt supp(gestion de tache) tu vois le topo
je regarde le reste mais bon comment veux tu travailler correctement avec ça
demain tu change d’écran ça ira plus

 

[patricktoulon]

re

déjà pour commencer

dans tes userform1 , userform2 ,userform8

met ceci avant le "end sub" de l'initialise

 '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
    'SCALE TO SCREEN                                      $
    '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


    Dim oldW#, oldH#, ctrl, CfnewW#, CFnewH#, D
    For Each ctrl In Me.Controls
        With ctrl
            .Tag = .Left & ";" & .Top & ";" & .Width & ";" & .Height
            On Error Resume Next
            .Tag = .Tag & ";" & .Font.Size
            Err.clar
        End With
    Next
    oldW = Me.Width: oldH = Me.Height
    Application.WindowState = xlMaximized

    With Me
        .Top = 0: .Left = 0
        .Width = Application.Width
        .Height = Application.Height
        CFnewH = Me.Height / oldH: CfnewW = Me.Width / oldW
        For Each ctrl In .Controls
            D = Split(ctrl.Tag, ";")
            With ctrl
                .Move D(0) * CfnewW, D(1) * CFnewH, D(2) * CfnewW, D(3) * CFnewH
                On Error Resume Next
                .Font.Size = D(4) * Application.Min(CfnewW, CFnewH)
                Err.Clear
            End With

        Next
    End With