XL 2019 simplifier un code

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
chinel

chinel

XLDnaute Impliqué
Bonjour tout le monde ! J'ai un code que je voudrais simplifier , merci
Dans mon cas, je dois copier des cellules dans la colle M mais peut-on le raccourcir ou dois-je mettre toute la même procédure que dans mon exemple ?
Les cellules à copier sont: B8,B10,B11,B12,B13,B14,B15,B17,B19,B20,B21,B22,B25,B26,B27,B28,B29,G8,G10,G11,G12,G13,G14,G15,G17,G19,G20,G21,G22,G237 (B8 étant déjà fait)

Dim Derlig&

With Sheets("Planning")
Derlig = .Range("M" & .Rows.Count).End(xlUp).Row + 1

.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B8").Value

.Range("M2:M" & Derlig + 1).RemoveDuplicates Columns:=1, Header:=xlNo
end with
 
Solution
D
Bonsoir
Bon je viens de passer un peu de temps pour t'écrire une petite macro qui te permet te faire ce que tu veux
La SEULE condition est de recopier ta liste de cellules concrète dans la SUB
Donc un morceau de ta liste de cellules dans la Sub à adapter !!
C'est juste une idée !!! selon ce que j'ai compris ...... Puisque PAS DE FICHIER joint ??
Trier par date Trier par votes
Bonsoir
Bon je viens de passer un peu de temps pour t'écrire une petite macro qui te permet te faire ce que tu veux
La SEULE condition est de recopier ta liste de cellules concrète dans la SUB
Donc un morceau de ta liste de cellules dans la Sub à adapter !!
C'est juste une idée !!! selon ce que j'ai compris ...... Puisque PAS DE FICHIER joint ??
 

Pièces jointes

Vote positif 0 Vote négatif
Solution
Bonsoir,
Un peu dans le même concept que @dev_co, à coller dans le module de feuille :
VB: 
Option Base 1
Sub test()
Dim plg As Range, cellule As Range, compteur%, derlig
Dim tbl()
derlig = Range("M" & Rows.Count).End(xlUp).Row + 1
Set plg = Range("B8,B10:B15,B17,B19:B22,B25:B29,G8,G10:G15,G17,G19:G22,G237")
compteur = 1
For Each cellule In plg
    If cellule <> "" Then
        ReDim Preserve tbl(compteur)
        tbl(compteur) = cellule
        compteur = compteur + 1
    End If
Next cellule
Range("M" & derlig).Resize(UBound(tbl)) = Application.Transpose(tbl)
End Sub
A +
 
Dernière édition:
Vote positif 0 Vote négatif
bonjour à tous
pourquoi faire simple quand on peut faire compliqué😉

VB: 
Sub test()
Dim plg As Range
With Feuil1                                           'feuille  à adapter
        Set plg = .Range("B8,B10:B15,B17,B19:B22,B25:B29,G8,G10:G15,G17,G19:G22,G237")
        plg.SpecialCells(xlCellTypeConstants).Copy .Cells(Rows.Count, "M").End(xlUp).Offset(1)
        .Range("M:M").RemoveDuplicates 1, xlNo
    End With
End Sub
 
Vote positif 0 Vote négatif
patricktoulon à dit:
bonjour à tous
pourquoi faire simple quand on peut faire compliqué😉

VB: 
Sub test()
Dim plg As Range
With Feuil1                                           'feuille  à adapter
        Set plg = .Range("B8,B10:B15,B17,B19:B22,B25:B29,G8,G10:G15,G17,G19:G22,G237")
        plg.SpecialCells(xlCellTypeConstants).Copy .Cells(Rows.Count, "M").End(xlUp).Offset(1)
        .Range("M:M").RemoveDuplicates 1, xlNo
    End With
End Sub
Cliquez pour agrandir...
cest vrai que ton code ne fonctionne pas 😕
 
Vote positif 0 Vote négatif
j'ai peut-être la solution mais sans certitudes 🤔

Dim Derlig& 'code pour coller les cellules dans la colonne M à la suite de l'autre sans doublons

With Sheets("Planning")
Derlig = .Range("M" & .Rows.Count).End(xlUp).Row + 1

.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B8").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B10").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B11").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B12").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B13").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B14").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B15").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B17").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B19").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B20").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B21").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B22").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B25").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B26").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B27").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B28").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("B29").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("G8").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g10").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g11").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g12").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g13").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g14").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g15").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g17").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g19").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g20").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g21").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g22").Value
.Range("M" & .Range("M" & .Rows.Count).End(xlUp).Row + 1).Value = Sheets("Planning").Range("g23").Value
.Range("M2:M" & Derlig + 1).RemoveDuplicates Columns:=1, Header:=xlNo
 
Dernière édition:
Vote positif 0 Vote négatif
re
oui autant pour moi je n'avais pas vu qu'il y avait 2 colonnes
VB: 
Sub test()
Dim p1 As Range, p2 As Range
With Feuil1                                           'feuille  à adapter
        Set p1 = .Range("B8,B10:B15,B17,B19:B22,B25:B29")
        Set p2 = .Range(" G8,G10:G15,G17,G19:G22,G237")
        p1.SpecialCells(xlCellTypeConstants).Copy .Cells(Rows.Count, "M").End(xlUp).Offset(1)
        p2.SpecialCells(xlCellTypeConstants).Copy .Cells(Rows.Count, "M").End(xlUp).Offset(1)

        .Range("M:M").RemoveDuplicates 1, xlNo
    End With
End Sub
demo.gif
 
Vote positif 0 Vote négatif
J'ai un soucis de doublon pourquoi ? Quand je modifie la valeur de A8

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A8,B:B,G:G]) Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
'If Target.Count > 1 Then Application.Undo: GoTo 1 'annule les entrées ou effacements multiples
If Range("A8") = "à l'arrêt" Then Range("B8,B10:B15") = "": GoTo 1
If Target = "" Or (Application.CountIf([B:B], Target) + Application.CountIf([G:G], Target)) = 1 Then GoTo 1
Target.Select
MsgBox "Cette personne est déjà dans le planning !", 48, "Doublon"
Target = ""
1 Application.EnableEvents = True 'réactive les évènements
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsoir
C'est bien de passer du temps pour aider ....... même que on s'en fout puisque on ne sait pas si la proposition fonctionne ?? , je pense qu'il y a WAIKY dans le même cas
Ma macro fonctionne selon les critères de la demande , mais si le résultat attendu ne va pas c'est que l'énoncé n'est pas assez précis
!! Bravo pour la politesse
 
Vote positif 1 Vote négatif
dev_co à dit:
Bonsoir
C'est bien de passer du temps pour aider ....... même que on s'en fout puisque on ne sait pas si la proposition fonctionne ?? , je pense qu'il y a WAIKY dans le même cas
Ma macro fonctionne selon les critères de la demande , mais si le résultat attendu ne va pas c'est que l'énoncé n'est pas assez précis
!! Bravo pour la politesse
Cliquez pour agrandir...
Bonsoir,
Complètement d'accord, nous pouvons clore le sujet !
A +
 
Vote positif 0 Vote négatif
Je présume que les commentaires me sont destinés alors je comprends vos messages de mécontentement mais j'ai eu de gros soucis au niveau familial donc je n'ai pas su répondre à tout le monde et j'en suis désolé 🙏 Bonne soirée et merci d'être là pour moi. Je n'ai pas encore eu le temps de voir les messages ni de tester ceux-ci, je regarde demain, merci encore !
 
Vote positif 0 Vote négatif
Wayki à dit:
Bonsoir,
Un peu dans le même concept que @dev_co, à coller dans le module de feuille :
VB: 
Option Base 1
Sub test()
Dim plg As Range, cellule As Range, compteur%, derlig
Dim tbl()
derlig = Range("M" & Rows.Count).End(xlUp).Row + 1
Set plg = Range("B8,B10:B15,B17,B19:B22,B25:B29,G8,G10:G15,G17,G19:G22,G237")
compteur = 1
For Each cellule In plg
    If cellule <> "" Then
        ReDim Preserve tbl(compteur)
        tbl(compteur) = cellule
        compteur = compteur + 1
    End If
Next cellule
Range("M" & derlig).Resize(UBound(tbl)) = Application.Transpose(tbl)
End Sub
Cliquez pour agrandir...
Bonjour, le code marche bien mais il y a des doublons dans la colonne M, merci
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
41
job75
job75
L
  • Résolu(e)
Microsoft 365 Trie par Date & Heure
Réponses
8
Affichages
444
Le Rouky
L
David Aubert
Optimisation de code VBA
Réponses
5
Affichages
78
Cléa
Cléa
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
N
  • Résolu(e)
Microsoft 365 Simplifier un code pour activer ou désactiver des CheckBox
6 7 8
Réponses
115
Affichages
3 K
ChTi160
ChTi160
C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
547
crazy
C
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
362
Oneida
Oneida
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
98
safranien
S
Nicolas JACQUIN
  • Question Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
703
TooFatBoy
TooFatBoy
S
  • Résolu(e)
XL 2016 Besoin d'aide pour un code d'extraction
Réponses
14
Affichages
592
Phil69970
Phil69970
J
  • Question Question
Microsoft 365 Code VBA
Réponses
10
Affichages
794
jebibo
J
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
219
patricktoulon
patricktoulon
M
  • Résolu(e)
Microsoft 365 Erreur code ou pas ?
2
Réponses
17
Affichages
907
Marvin57
M
chinel
  • Résolu(e)
XL 2019 code vba pour copier cellule
2
Réponses
20
Affichages
1 K
chinel
chinel
A
  • Question Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
445
Phil69970
Phil69970
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
334
Gestionnaire_rh
G
L
  • Question Question
VBA : erreur sur boucle
Réponses
2
Affichages
302
Latias
L
chris6999
  • Question Question
Microsoft 365 Boucle VB pour supprimer les caractères spéciaux et numériques d'une chaîne
Réponses
5
Affichages
444
patricktoulon
patricktoulon
C
  • Question Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
432
CathyLD
C
R
  • Question Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
651
Dranreb
Dranreb
Retour