XL 2016 problème des cellules fusionnées

amateur

XLDnaute Nouveau
Bonjour à vous, j'ai actuellement un problème avec des cellules fusionnées !!!
voici actuellement mon programme qui fonctionne très bien (sauf pour les cellules fusionnées )
VB:
Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True

Dim rLignes As Range, rCols As Range, plage As Range, c As Range
Dim ref As String

Set rLignes = Union(Rows("15"), Rows("20"), Rows("25"), Rows("30"), Rows("35"), Rows("40"), Rows("45"), Rows("50"), Rows("55"), Rows("60"))
Set rCols = Range("E:E, G:G, I:I, K:K, M:M")
Set plage = Intersect(rLignes, rCols)

If Not Intersect(Target, plage) Is Nothing Then

    If Target.Value <> "" Then
       ref = Target.Value
    Else
        MsgBox "Référence incorrecte"
        Exit Sub
    End If

    With Worksheets("Feuil4").Columns(1)
        Set c = .Find(Target.Value)
        If Not c Is Nothing Then
           
            c.EntireRow.Copy Destination:=Sheets("Feuil5").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Else
            MsgBox "Référence inexistante"
            Exit Sub
        End If
    End With

End If

End Sub
j'ai donc 2 possibilité : -soit je reprend tout les tableaux qui font quelques milliers de de lignes avec une quarantaine de colonne (cette solution ne m'arrange pas)
-soit j'arrive à détecter quelles cellules sont fusionnées et je copie entièrement les plusieurs lignes où quelques cellules on étaient fusionnées

Je souhaiterais donc réalisé la deuxième solution car c'est fortement arrangeant.
Le problème c'est que je ne sait absolument pas quoi codé pour mettre à bien mon envie, pourriez vous m'aider SVP

Bien cordialement A.
 
Solution
Bonsoir amateur,

tu as noté : « le programme que tu as écrit est génial !! » ; merci pour ton retour !! 😊 j'espère que tu as aussi noté comment je vérifie si c'est la bonne position d'une cellule, sans avoir à utiliser Union(), ni en devant énumérer toutes les lignes puis toutes les colonnes. ;)

à propos des msgbox, j'ai corrigé le petit défaut, et même je les ai beaucoup améliorées ! 😊 je te laisse faire tous les tests, y compris le clic droit sur une cellule vide ; si ça te convient pour les nouvelles MsgBox, j'ajouterai des commentaires dans le code VBA.​

VB:
Option Explicit

Dim b As Byte

Private Sub Job(ref$, k As Byte)
  Dim s1$, s2$, c As Range, n1 As Byte, n2 As Byte...

soan

XLDnaute Barbatruc
Inactif
Bonjour amateur, Staple,

ton fichier en retour. :)

je n'ai pas utilisé tes 2 feuilles "xx" et "x" car je pense que tu t'en sers comme modèles ; sans quoi, il m'aurait suffit de les renommer correctement pour pouvoir les utiliser ; j'ai ajouté les 2 feuilles nécessaires : regarde d'abord "API ATB", puis "E-test" ; tu peux voir que sur ces 2 feuilles, il n'y a que les 2 lignes d'en-têtes, donc y'a aucune ligne de donnée.

va sur la feuille "Programme Initial" ; fais un clic droit sur les cellules adéquates et vérifie les résultats.​

VB:
Option Explicit

Dim b As Boolean

Private Sub Job(ref$, k As Byte)
  Dim s1$, s2$, msg$, c As Range, n1 As Byte, n2 As Byte, lig&
  If k = 9 Then
    s2 = "E-test": msg = "référence API ATB"
  Else
    s1 = " 2": s2 = "API ATB": msg = "référence E-test ou inexistante"
  End If
  Set c = Worksheets("tableau à extraire" & s1).Columns(1).Find(ref, , -4163, 1, 1)
  If Not c Is Nothing Then
    With Worksheets(s2)
      n1 = c.MergeArea.Rows.Count: b = -1
      lig = .Cells(Rows.Count, 1).End(3).Row
      n2 = .Cells(lig, 1).MergeArea.Rows.Count
      c.Resize(n1, k).Copy .Cells(lig + n2, 1)
    End With
  Else
    MsgBox msg: b = 0
  End If
End Sub

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Cancel = True
  With Target
    If .CountLarge > 1 Then Exit Sub
    Dim col%: col = .Column: If col < 5 Or col > 13 Or col Mod 2 = 0 Then Exit Sub
    Dim lig&: lig = .Row: If lig < 15 Or lig > 60 Or lig Mod 5 > 0 Then Exit Sub
    Dim ref$: ref = .Value: If ref = "" Then MsgBox "Référence inexistante": Exit Sub
  End With
  Job ref, 9: If Not b Then Job ref, 29
End Sub

si besoin, tu peux demander une adaptation.
à te lire pour avoir ton avis. ;)

soan
 

Pièces jointes

  • le planning 1 er programme.xlsm
    101.8 KB · Affichages: 7

amateur

XLDnaute Nouveau
Bonjour soan,
le programme que tu as écris est génial !! le fait d'extraire les données et les remettre dans les feuilles en détectant le nombre de colonne correspondant est une extraction astucieuse ;)
Je ne comprend pas tout ton programme, serait-il possible que tu y ajoute quelques commentaires pour me facilité la compréhension (je suis un amateur)?
Il y a un petit défaut avec les msgbox lors du clic sur un ref E-test celle-ci n'apparait pas, par contre avec un clic sur une ref API la msgbox apparait bien et sur une référence inconnu les deux msgbox apparaissent. Il faudrait que la msgbox apparaisse bien lors d'un clic sur une ref e-test, n'ayant compris qu'en partis ton programme je n'arrive pas à modifier cela comme je le souhaite.
 

soan

XLDnaute Barbatruc
Inactif
Bonsoir amateur,

tu as noté : « le programme que tu as écrit est génial !! » ; merci pour ton retour !! 😊 j'espère que tu as aussi noté comment je vérifie si c'est la bonne position d'une cellule, sans avoir à utiliser Union(), ni en devant énumérer toutes les lignes puis toutes les colonnes. ;)

à propos des msgbox, j'ai corrigé le petit défaut, et même je les ai beaucoup améliorées ! 😊 je te laisse faire tous les tests, y compris le clic droit sur une cellule vide ; si ça te convient pour les nouvelles MsgBox, j'ajouterai des commentaires dans le code VBA.​

VB:
Option Explicit

Dim b As Byte

Private Sub Job(ref$, k As Byte)
  Dim s1$, s2$, c As Range, n1 As Byte, n2 As Byte, lig&
  If k = 9 Then s2 = "E-test" Else s1 = " 2": s2 = "API ATB"
  Set c = Worksheets("tableau à extraire" & s1).Columns(1).Find(ref, , -4163, 1, 1)
  If c Is Nothing Then b = 0: Exit Sub
  With Worksheets(s2)
    n1 = c.MergeArea.Rows.Count: b = 1: lig = .Cells(Rows.Count, 1).End(3).Row
    n2 = .Cells(lig, 1).MergeArea.Rows.Count: c.Resize(n1, k).Copy .Cells(lig + n2, 1)
    MsgBox "« " & ref & " » a été écrit" & vbLf & "en feuille " _
      & s2 & ".", 64, "Réf " & IIf(s1 = "", s2, "API")
  End With
End Sub

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  Cancel = True
  With Target
    If .CountLarge > 1 Then Exit Sub
    Dim col%: col = .Column: If col < 5 Or col > 13 Or col Mod 2 = 0 Then Exit Sub
    Dim lig&: lig = .Row: If lig < 15 Or lig > 60 Or lig Mod 5 > 0 Then Exit Sub
    Dim ref$: ref = .Value
    If ref = "" Then MsgBox "Il n'y a pas de référence.", 48, "Cellule vide": Exit Sub
  End With
  Job ref, 9: If b = 0 Then Job ref, 29
  If b = 0 Then MsgBox _
    "« " & ref & " » est dans aucun des 2 tableaux.", 48, "Réf non trouvée"
End Sub

soan
 

Pièces jointes

  • le planning 1 er programme.xlsm
    102.7 KB · Affichages: 6
Dernière édition:

soan

XLDnaute Barbatruc
Inactif
Bonjour amateur,

comme tu m'as confirmé que les nouvelles MsgBox te conviennent, voici donc le code VBA commenté :​



Dim b As Byte : variable globale (niveau Module) : contiendra 0 = non trouvé ; ou 1 = trouvé.



sub Worksheet_BeforeRightClick() :

Cancel = True : pour annuler l'affichage du menu contextuel.

With Target .. End With : avec Target, qui représente les cellules de la sélection en cours ou une seule cellule.

If .CountLarge > 1 Then Exit Sub : sortie si plus d'une cellule est sélectionnée ; donc la suite va être exécutée uniquement si on a fait un clic droit sur une seule cellule.

Dim col% : idem que Dim col As Integer
col = .Column : col contient le n° de colonne de la cellule active.
If col < 5 Or col > 13 Or col Mod 2 = 0 Then Exit Sub : sortie de la sub :
* si col < 5, donc si col < E ➯ si la colonne est A à D
* si col > 13, donc si col >M ➯ si la colonne est N ou plus à droite
* si col modulo 2 = 0, donc si le n° colonne est pair ; sur E:M, c'est : col = F, H, J, ou L
* donc la suite est exécutée que pour les colonnes impaires E ; G ; I ; K ; M

Dim lig& : idem que Dim lig As Long
lig = .Row : lig contient le n° de ligne de la cellule active.
If lig < 15 Or lig > 60 Or lig Mod 5 > 0 Then Exit Sub : sortie de la sub :
* si lig < 15 ➯ si la ligne est 1 à 14
* si lig > 60 ➯ si la ligne est 61 ou plus bas
* si lig modulo 5 > 0, donc pour 1 à 4
* donc la suite est exécutée que pour les lignes 15 à 60 ET que le n° ligne est un multiple de 5 (le modulo retourne 0) ; donc que pour ces lignes : 15 ; 20 ; 25 ; 30 ; 35 ; 40 ; 45 ; 50 ; 55 ; 60​

Dim ref$ : idem que Dim ref As String
ref = .Value : ref (la référence) contient la valeur de la cellule active.

If ref = "" Then MsgBox "Il n'y a pas de référence.", 48, "Cellule vide": Exit Sub : si ref est une chaîne de caractères vide, on affiche le message "Il n'y a pas de référence." et on sort de la sub ; en effet, si la cellule est vide, y'a pas besoin de faire une recherche.

la suite est donc exécutée seulement si la cellule n'est pas vide, donc s'il y a effectivement une référence ; or on ne peut pas savoir à l'avance si cette référence va être trouvée dans le tableau de la dernière feuille, ou si elle va être trouvée dans le tableau de l'avant-dernière feuille, ou peut-être qu'elle sera dans aucun des 2 tableaux ; on va donc faire une 1ère recherche sur la feuille "tableau à extraire", qui est de 9 colonnes A à I ; d'où ce 1er appel : Job ref, 9 ; c'est la sub Job() qui fait la recherche dans une feuille ; en sortie de cette sub Job(), b = 0 ou 1 (non trouvé ou trouvé).

If b = 0 Then Job ref, 29 : c'est seulement si la référence n'a pas déjà été trouvée sur la 1ère feuille qu'on va faire une 2ème recherche sur la 2ème feuille "tableau à extraire 2", qui est de 29 colonnes A à AC ; en sortie de la sub Job(), même chose : b = 0 ou 1 (non trouvé ou trouvé).​

If b = 0 Then MsgBox "« " & ref & " » est dans aucun des 2 tableaux.", 48, "Réf non trouvée"
c'est seulement si la référence n'a pas non plus été trouvée sur la 2ème feuille qu'on affiche le message « ref » est dans aucun des deux tableaux, ref étant la référence réelle et pas le texte "ref".​



sub Job() :

Private Sub Job(ref$, k As Byte) : la sub Job reçoit donc 2 valeurs : la référence ref et le nombre de colonnes (9 ou 29) qui est mis dans k.

Dim s1$, s2$, c As Range, n1 As Byte, n2 As Byte, lig& : déclaration de plusieurs variables ; bien noter qu'au départ, s1 et s2 sont 2 chaînes de caractères vides.

If k = 9 Then s2 = "E-test" Else s1 = " 2": s2 = "API ATB" :
* si k = 9 : il s'agit de l'appel de Job() pour une recherche sur la 1ère feuille de 9 colonnes ; et dans ce cas : a) de façon implicite, s1 reste vide ; b) s2 = "E-test"
* si k = 29 : il s'agit de l'appel de Job() pour une recherche sur la 2ème feuille de 29 colonnes ; et dans ce cas : a) s1 = " 2" ; b) s2 = "API ATB"

Set c = Worksheets("tableau à extraire" & s1).Columns(1).Find(ref, , -4163, 1, 1)
voici la recherche de la référence ref faite par le .Find ; selon s1, on fait cette recherche soit sur la 1ère feuille "tableau à extraire", soit sur la 2ème feuille "tableau à extraire 2" ; cette recherche est faite en colonne 1, donc en colonne A ; avec -4163, c'est une recherche par valeur (xlValues) ; le premier 1 est pour xlWhole et le deuxième 1 est pour xlByRows.

If c Is Nothing Then b = 0: Exit Sub : si la référence n'a pas été trouvée en colonne A, alors b = 0 et sortie ; noter qu'on n'affiche encore aucun message car s'il y aura une 2ème recherche, la référence sera peut-être trouvée sur la 2ème feuille.

la suite de la sub Job() va donc être exécutée uniquement si la référence a été trouvée en colonne A.

With Worksheets(s2) : avec la feuille s2 ; donc soit avec la feuille "E-test", soit avec la feuille "API ATB" (c'est donc bien la feuille de résultats où il faut copier la ligne de la référence du tableau source)

n1 = c.MergeArea.Rows.Count : n1 = nombre de lignes de la cellule trouvée : 2 si fusion de 2 lignes, 1 si pas de fusion.
b = 1 : on indique que la référence a été trouvée.

lig = .Cells(Rows.Count, 1).End(3).Row : n° de la dernière ligne utilisée, selon la colonne A ; 3 = xlUp ; attention : c'est volontairement qu'il n'y a pas de +1 ! ce n'est pas un oubli ! car il faut tester le nombre de lignes si c'est une fusion ! et c'est d'ailleurs là la cause de l'erreur que tu avais eue, car ça cherchait à écrire à cet endroit, donc par-dessus une fusion éventuelle ! et plantage en cas de fusion !

n2 = .Cells(lig, 1).MergeArea.Rows.Count : n2 = nombre de lignes de la dernière cellule utilisée en colonne A ; 2 si fusion de 2 lignes, 1 si pas de fusion.

c.Resize(n1, k).Copy .Cells(lig + n2, 1) : ne pas oublier que c est la cellule de la référence qui a été trouvée en colonne A ; on redimensionne cette unique cellule sur n1 lignes et sur k colonnes ; c'est donc sur 2 lignes ou 1 seule selon qu'il y a ou non une fusion, et c'est sur k colonnes (9 ou 29 selon la feuille sur laquelle on a fait la recherche) ; et fait-on le coller ? en colonne 1 = colonne A ; en ligne lig + n2 : et voilà, c'est grâce à cela qu'on évite l'erreur initiale d'écriture sur une cellule fusionnée ! 😊

reste plus que le message de confirmation d'écriture de la référence :

VB:
MsgBox "« " & ref & " » a été écrit" & vbLf & "en feuille " _
  & s2 & ".", 64, "Réf " & IIf(s1 = "", s2, "API")

ref a été écrit en feuille s2 (donc en feuille "E-test" ou en feuille "API ATB") ; noter que le titre du MsgBox est soit "Réf E-test", soit "Réf API" ; 64 est pour l'icône i bleu (information).​



voilà, c'était très long, et en plus c'est un des codes les plus durs que j'ai eu à commenter !
à te lire pour avoir ton avis. ;)

soan
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour amateur, JM, soan,

Dans ce genre de problème il est bien de permettre la sélection multiple des cellules :
VB:
Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Application.CountA(Target) = 0 Then Exit Sub
Dim a, b, i%, c As Range
a = Array("tableau à extraire", "tableau à extraire 2") 'feuilles sources
b = Array("E-test", "API ATB") 'feuilles de destination
Cancel = True
For Each Target In Intersect(Target, Target.SpecialCells(xlCellTypeConstants)) 'si sélection multiple
    For i = 0 To UBound(a)
        Set c = Sheets(a(i)).Columns(1).Find(Target, , xlValues, xlWhole) 'recherche en colonne A
        If Not c Is Nothing Then
            With Sheets(b(i)).UsedRange
                c.MergeArea.EntireRow.Copy .Cells(.Rows.Count + 1, 1)
            End With
            MsgBox "'" & Target & "' a été collé dans la feuille '" & b(i) & "'"
        End If
Next i, Target
End Sub
Testez le fichier joint en faisant par exemple un clic droit sur la colonne G entière.

A+
 

Pièces jointes

  • le planning 1 er programme (1).xlsm
    97.9 KB · Affichages: 3

job75

XLDnaute Barbatruc
Pour la recherche il vaut mieux utiliser Application.Match (EQUIV) plutôt que Find, fichier (2) :
VB:
Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Application.CountA(Target) = 0 Then Exit Sub
Dim a, b, i%, j As Variant
a = Array("tableau à extraire", "tableau à extraire 2") 'feuilles sources
b = Array("E-test", "API ATB") 'feuilles de destination
Cancel = True
For Each Target In Intersect(Target, Target.SpecialCells(xlCellTypeConstants)) 'si sélection multiple
    For i = 0 To UBound(a)
        j = Application.Match(Target, Sheets(a(i)).Columns(1), 0) 'recherche en colonne A
        If IsNumeric(j) Then
            With Sheets(b(i)).UsedRange
                Sheets(a(i)).Cells(j, 1).MergeArea.EntireRow.Copy .Cells(.Rows.Count + 1, 1)
            End With
            MsgBox "'" & Target & "' a été collé dans la feuille '" & b(i) & "'"
        End If
Next i, Target
End Sub
C'est bien plus rapide et en outre les cellules vides sont ignorées quand on sélectionne des cellules fusionnées.

Testez en sélectionnant toutes les cellules de la feuille "Programme Initial".
 

Pièces jointes

  • le planning 1 er programme (2).xlsm
    98.1 KB · Affichages: 2

job75

XLDnaute Barbatruc
Pour éviter d'utiliser le UsedRange on peut insérer les valeurs en dessous des titres, fichier (3) :
VB:
Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Application.CountA(Target) = 0 Then Exit Sub
Dim a, b, ligne, i%, j As Variant
a = Array("tableau à extraire", "tableau à extraire 2") 'feuilles sources
b = Array("E-test", "API ATB") 'feuilles de destination
ligne = Array(3, 2) 'lignes pour l'insertion
Cancel = True
For Each Target In Intersect(Target, Target.SpecialCells(xlCellTypeConstants)) 'si sélection multiple
    For i = 0 To UBound(a)
        j = Application.Match(Target, Sheets(a(i)).Columns(1), 0) 'recherche en colonne A
        If IsNumeric(j) Then
            Sheets(a(i)).Cells(j, 1).MergeArea.EntireRow.Copy
            Sheets(b(i)).Rows(ligne(i)).Insert 'insertion en dessous des titres
            MsgBox "'" & Target & "' a été collé dans la feuille '" & b(i) & "'"
        End If
Next i, Target
Application.CutCopyMode = 0
End Sub
 

Pièces jointes

  • le planning 1 er programme (3).xlsm
    98.3 KB · Affichages: 3

Discussions similaires

Réponses
1
Affichages
204

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof