XL 2019 simplifier un code

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
D

dev_co

XLDnaute Occasionnel
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

  • copyList.xlsm
    20.7 KB · Affichages: 5
Vote positif 0 Vote négatif
Solution
Wayki

Wayki

XLDnaute Impliqué
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
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
chinel

chinel

XLDnaute Impliqué
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 :confused:
 
Vote positif 0 Vote négatif
chinel

chinel

XLDnaute Impliqué
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
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
chinel

chinel

XLDnaute Impliqué
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

  • Planning d'équipe 2023.xlsm
    53.7 KB · Affichages: 1
Vote positif 0 Vote négatif
D

dev_co

XLDnaute Occasionnel
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
Wayki

Wayki

XLDnaute Impliqué
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
chinel

chinel

XLDnaute Impliqué
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
chinel

chinel

XLDnaute Impliqué
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

Discussions similaires

C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
327
crazy
C
S
  • Résolu(e)
XL 2016 Besoin d'aide pour un code d'extraction
Réponses
14
Affichages
274
Phil69970
Phil69970
chinel
  • Résolu(e)
XL 2019 code vba pour copier cellule
2
Réponses
20
Affichages
887
chinel
chinel
M
  • Question
XL 2016 copie valeurs par VBA
Réponses
5
Affichages
291
mcj1997
M
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
117
Phil69970
Phil69970
M
  • Résolu(e)
Microsoft 365 Erreur code ou pas ?
2
Réponses
17
Affichages
340
Marvin57
M
chinel
  • Question
XL 2019 soucis avec un code VBA pour les doublons
2
Réponses
20
Affichages
769
chinel
chinel
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
188
aziz
A
R
  • Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
373
Dranreb
Dranreb
E
  • Question
XL 2013 vba excel
Réponses
6
Affichages
246
sylvanu
sylvanu

Membres actuellement en ligne

4 membres et 57 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 215
Messages
2 086 330
Membres
103 187
dernier inscrit
ebenhamel