Copier et coller des cellules fusionnées
Bonjour forumeur,
Quelqu'un aurai un bon code de copier coller des cellules fusionnée, ou même une idée à m'indiquer, car j'ai simulé avec une macro et c'est trop moche il faut je trouve une syntaxe qu'il ne dépasse pas une dizaine de ligne, je sais que le mot clé c'est merge, mais je ne saurais maîtrisé la méthode merge avec tous ses propriété (désolé si je dis des bêtise).
Donc si il y a une personne qu'il s'y connaît merci de m'indiquer le chemin à suivre.
je vous monte ce que j'ai fait:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''doublon '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If Range(Cells(PreLig, PreCol), Cells(DerLig, DerCol)) = "" Then
For CptLg = PreLig To DerLig
' For CptCol = PreCol To DerCol
If Cells(CptLg, DerLig) = "" Then
If Cells(CptLg - 1, DerLig) <> "" And Cells(CptLg + 1, CptCol) <> "" Then ' ERREUR1004
' ERREUR DEFINIE PAR L'APPLICATION OU PAR L'OBJET!!!!!!!
' Cells(CptLg, CptCol) = "effacer"
' Cells(CptLg, 15) = "fusion"
' Cells(CptLg + 1, CptCol).Copy Cells(CptLg, CptCol)
' Cells(CptLg, CptCol) = "effacer"
Cells(CptLg, DerLig).Select
Cells(CptLg, DerLig).UnMerge
Cells(CptLg + 1, DerLig).Copy Cells(CptLg, DerLig - 1)
' Cells(CptLg, DerLig).Merge
' MsgBox "Voulez vous choisir un choix parmis les listes!"
End If
End If
' Next
Next
' End If
End Subquelle application , et quel objet il parle l'erreur?
merci de vos visites et vos commentaires
Cordialement
Bonjour
Généralement cette erreur est déclenchée si une valeur est égale à 0
Testes CptLg - 1 ou CptCol
Mais sans fichier en expliquant ce que tu veux faire, pas facile de t'aider
Bonjour à tous,
Merci Banzaï64, ouah tu m'aides même à une heure pareil merci ,c'était bien une erreur tout bête, j'ai regardé les CptLig et CptCol et s'avère que j'ai initié à des valeurs qui ne correspondait pas le tableaux et que je confondais avec DerCol et DerLig.
Donc j'ai ajouté une autre variable DerLigCol qui regarde la dernière ligne de chaque colonne(je sais j'ai qu'une seule colonne c'est juste pour l'exemple
J'ai trouvé le code pour copier et coller des cellules fusionnées(mais j'ai triché
voici le code :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''CONSTRUCTION DES TABLEAU AUTOMATIQUEMENT SELON LE CHOIX DES LISTES'''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'variable
Dim PreLig As Integer
Dim PreCol As Integer
Dim DerLig As Long
Dim DerCol As Long
Dim DerLigCol As Long
Dim NbLigne As Integer
Dim Colonne As Integer
Dim Ligne As Integer
Dim Cpt As Integer
Dim CptLg As Integer
Dim CptCol As Integer
Dim CptLigCol As Integer
Dim CptM As Integer
Dim CptDlt As Integer
Dim cel1 As Range, Cel2 As Range
Dim cel3 As Range, Cel4 As Range
Dim chaine As String
' initialisation des variables
PreLig = 8
PreCol = 11
DerCol = 11
DerLig = 17
For CptLigCol = PreCol To DerCol
DerLigCol = Cells(Rows.Count, CptLigCol).End(xlUp).Row
Next
' MsgBox DerLigCol
' Set cel1 = Cells(Cpt, Colonne + 1)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''si cellules vide alors copie la sellule en dessous est colle dans la cellule vide''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For CptLg = PreLig To DerLig
If Cells(CptLg, DerCol) = "" Then
If Cells(CptLg - 1, DerCol) <> "" And Cells(CptLg + 1, DerCol) <> "" Then
' compteur pour défusionner chaque cellule depuis la cellule vide
For CptM = CptLg To DerLig
Cells(CptM, DerCol).UnMerge
Next
'copie des cellules collers à n-1
Range(Cells(CptLg + 1, DerCol), Cells(DerLig, DerCol)).Copy Range(Cells(CptLg, DerCol), Cells(DerLigCol, DerCol))
'compteur pour fusionner chaque cellule
For CptM = CptLg To DerLig
Range(Cells(CptM, DerCol), Cells(CptM, DerCol + 2)).Merge
Next
End If
End If
NextJ'ai un soucis sur la partie doublons, je souhaiterai ne pas autoriser les doublons si c'était en sql sa serait facile et en vba comment on fait pour automatiser le refus de doublons. Ce que j'aimerai encore mieux faire c'est de supprimer le mot choisi directement dans la liste est ce possible.
Je vous met le code mais sa ne fonctionne pas car il est trop "stu...." ce code. il me renvoie vrai ou faux ce que j'ai surligné et écris doublon sur la colonne N
(c'est moi qui est demandé d'écrire doublons là il y a un doublons
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''doublons'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For CptLg = PreLig To DerLigCol - 1
For CptDlt = PreLig + 1 To DerLigCol
If Cells(CptLg, DerCol) = Cells(CptDlt, DerCol) Then
Cells(CptLg, DerCol + 3) = "doublons"
End If
Next 'Exit Sub
Next
End SubJe vous joints le fichier pour ceux qu'ils veulent un exemple.
J'espère trouver une réponse avant se soir.
Merci Banzaï encore
Bonjour
Dans le fichier qui n'est passé donne un exemple du résultat attendu
Cela facilitera la compréhension du problème (enfin je crois)
bonjour forum et à tous et toi banzai64,
j'ai trouvé voilà la solution :
For CptLg = PreLig To DerLigCol - 1
For CptDlt =CptLg + 1 To DerLigCol
If (Cells(CptLg, DerCol) = Cells(CptDlt, DerCol)) Then
Cells(CptDlt, DerCol + 3) = "doublons"
End If
Next 'Exit Sub
Pour le deuxième compteur je dois partir de la ligne courante +1
Merci d'avoir jeter un oeil
cordialement
Bonjour
A voir si c'est ce que tu cherches (pas trop testé)
EDIT à 12:56 : Remplacement de la macro
Remplaces ta macro dans le module de la feuille "Tableau"
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Mondico As Object
Dim J As Long
If Not Intersect(Range("L8:L17"), Target) Is Nothing Then
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
For J = 8 To 17
If Range("K" & J) <> "" Then
Mondico(Range("K" & J).Value) = ""
End If
Next J
Range("S8:S17") = ""
Range("S8").Resize(Mondico.Count) = Application.Transpose(Mondico.keys)
Application.EnableEvents = True
End If
End SubBonjour Banzaï64,
C'est excellent ce que tu as fais, je n'ai plus besoin de dé fusionner et de fusionner la suppression ou le doublon
merci pour ce code optimisé, peux tu le commenter?
sa répond à ma problématique mieux que ma réponse
maintenant je vais la rendre autonome sans qu'on sache quel colonne on procède.
merci encore
ps=quand tu changes tous il faut que sa intervienne sur la même colonne c'était un exemple avant et après sur le même tableau pas deux tableaux différents je vais bidouiller ton code pour faire ce que je souhaite
BonjourBanzaï64,
Le bout de code que tu m'as envoyé je ne peux le modifier pour un tableau à plusieurs colonne.
Peux tu jeter un oeil pour ou mois sept colonne de plus.
le code de ce que j'ai fait en partant du tiens:
For CptCol = PreCol To DerCol
If Not Intersect(Range(Cells(PreLig, CptCol), Cells(DerLig, CptCol)), Target) Is Nothing Then
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
For J = PreLig To DerLig
If Cells(J, CptCol) <> "" Then
Mondico(Cells(J, CptCol).Value) = ""
End If
Next J
Range(Cells(PreLig, CptCol), Cells(DerLig, CptCol)) = ""
Cells(PreLig, CptCol).Resize(Mondico.Count) = Application.Transpose(Mondico.keys)
Application.EnableEvents = True
End If
Next CptColil beugue au moment qu'il a intervient sur une autre colonne et ensuite il ouvre un autre projetVBA dans l'éditeur vb
merci encore je cherche de mon cotés
Bonjour
Expliques ce que tu veux faire
Ce que j'ai compris c'est que tu veux "nettoyer" la colonne qui est modifiée
Essayes ce code
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable
Dim PreLig As Long, DerLig As Long, J As Long
Dim PreCol As Integer, DerCol As Integer
Dim Mondico As Object
' initialisation des variables
PreLig = 8
PreCol = 11
DerCol = 31
DerLig = 17
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''si cellules vide alors copie la sellule en dessous est colle dans la cellule vide''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not Intersect(Range(Cells(PreLig, PreCol), Cells(DerLig, DerCol)), Target) Is Nothing Then
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
For J = PreLig To DerLig
If Cells(J, Target.Column) <> "" Then
Mondico(Cells(J, Target.Column).Value) = ""
End If
Next J
Range(Cells(PreLig, Target.Column), Cells(DerLig, Target.Column)) = ""
Cells(PreLig, Target.Column).Resize(Mondico.Count) = Application.Transpose(Mondico.keys)
Application.EnableEvents = True
End If
End SubBonjour banzaï64, et à vous tous,
j'ai trouvé le code qui fonctionne. mais le tiens st mieux pas besoin de boucle pour pour parcourir les colonne merci.
Ce que j'ai fait dit moi ce que tu en penses? Mais je vais prendre le tiens merci
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable
Dim PreLig As Integer
Dim PreCol As Integer
Dim DerLig As Long
Dim DerCol As Long
Dim CptCol As Integer
Dim Mondico As Object
Dim CptLig As Long
' initialisation des variables
PreLig = 8
PreCol = 11
DerCol = 29
DerLig = 17
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''si cellules vide alors copie la sellule en dessous est colle dans la cellule vide''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For CptCol = PreCol To DerCol Step 3
If Not Intersect(Range(Cells(PreLig, CptCol), Cells(DerLig, CptCol)), Target) Is Nothing Then
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
For CptLig = PreLig To DerLig - 1
If Cells(CptLig, CptCol) <> "" Then
Mondico(Cells(CptLig, CptCol).Value) = ""
End If
Next CptLig
Range(Cells(PreLig, CptCol), Cells(DerLig, CptCol)) = ""
Cells(PreLig, CptCol).Resize(Mondico.Count) = Application.Transpose(Mondico.keys)
Application.EnableEvents = True
End If
Next CptCol
End Submerci de ton aide Banzaï64
Re Banzai,
mais il y a un gros beugue si le tableau est vide, tu as une solution j'ai mis une condition si range("N8:AE17")<>"" alors vérifie doublon sinon exit sub mais sa ne veut pas fonctionner même quand le tableau est vide sa me donné une erreur qui dit : erreur d'exécution 13 incompatibilité de type
désolé de t'embêter
Bonjour
Oui c'est vrai pas testé
rajoutes les lignes surlignées
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable
Dim PreLig As Long, DerLig As Long, J As Long
Dim PreCol As Integer, DerCol As Integer
Dim Mondico As Object
' initialisation des variables
PreLig = 8
PreCol = 11
DerCol = 31
DerLig = 17
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''si cellules vide alors copie la sellule en dessous est colle dans la cellule vide''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not Intersect(Range(Cells(PreLig, PreCol), Cells(DerLig, DerCol)), Target) Is Nothing Then
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
For J = PreLig To DerLig
If Cells(J, Target.Column) <> "" Then
Mondico(Cells(J, Target.Column).Value) = ""
End If
Next J
If Mondico.Count > 0 Then
Range(Cells(PreLig, Target.Column), Cells(DerLig, Target.Column)) = ""
Cells(PreLig, Target.Column).Resize(Mondico.Count) = Application.Transpose(Mondico.keys)
End If
Application.EnableEvents = True
End If
End SubPour ton code je pense que c'est inutile de reboucler sur toutes les colonnes
et le fait de recréer le même objet je ne sais pas ce que cela donne
Re,
merci cela fonctionne bien.
Bon je m'attaque à une autre partie.
merci pour ton avis sur mon code