Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
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
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...
Le premier problème, c'est qu'il manque un fichier exemple joint par tes soins.
Qui si il était joint nous éviterait de "perdre" du temps à recréer un classeur qui existe déjà sur ton disque dur.
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.
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.
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
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 où 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 :
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.
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.
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".
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
Je te remercie grandement pour le temps que tu as pris à commenter le programme que tu as écris (j'ai mis du temps à répondre, j'étais un peu occupé). tu as super bien expliqué, un grand merci à toi cela m'a beaucoup aidé !!!!
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
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. 
