Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Novice VBA - Copier coller cellule non vide dans autre onglet

Caroaix

XLDnaute Nouveau
Bonjour à tous,
Je cherche depuis un certain temps à faire une macro pour pouvoir copier-coller des cellules non vides dans un autre onglet.
  1. dans l'onglet Det. Week 1&2 = récupérer date en C2
  2. dans l'onglet Det. Week 1&2 récupérer les cellules non vides d'horaires de shift de la colonne C (ex C15)
  3. les insérer dans l'onglet "colored shifts" en colonne B
  4. Cela pour toutes les colonnes avec date
Dans un deuxième temps et pour aller plus loin je voudrais pouvoir mettre en face de chaque shift dans l'onglet "colored shifts" la barre couleur correspondante.

Je joins un fichier d'exemple.

Pour le moment, je suis arrivée à ce code qui ne fonctionne pas juste pour les cellules non vides de la colonne C :

Sub CutData()

Dim MotCle

Dim i As Byte

Dim C As Range

Dim F As String

Dim Ligne As Long

'On définit les mots clés

MotCle = Array("Open => 1:45 pm", "Open => 2:45 pm", "Middle 12 => 4 pm", "Middle 12 => 5 pm", “MIT”, “Middle 1 => 6 pm”, “Load”, “Middle EXC.”, “Unusual”, “Close <= 4:15 pm”, “Close <= 5:15 pm” )

'On effectue la recherche de chaque mot clé dans la colonne F de la sheet1

For i = 0 To UBound(MotCle)

Do

Set C = Worksheets("Det. Week1&2").Columns(6).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)

'Si le mot clé est trouvé

If Not C Is Nothing Then

'On définit le nom de la feuille où sera effectuée la copie

F = "Colored shifts" & (i + 2)

With Worksheets(F)

'On définit la ligne où sera effectué le collage

Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1

'On effectue le copier / coller

C.EntireRow.Copy .Range("A" & Ligne)

'On supprime la ligne dans la sheet1

C.EntireRow.Delete

End With

End If

Loop While Not C Is Nothing

Next i

End Sub


Si quelqu'un peut m'aider.
D'avance merci
 

Pièces jointes

  • Exemple pour planning macro.xlsx
    31.9 KB · Affichages: 13

Robert

XLDnaute Barbatruc
Repose en paix
Bonsoir Caro et bienvenue, bonsoir le forum,

Je t'avoue que ta requête et ton code son assez éloignés. Alors si j'ai bien compris, ce qui est rare, essaie comme ça :

VB:
Sub Macro1()
Dim OC As Worksheet 'déclare la variable OC (Onglet Colored)
Dim OW As Worksheet 'déclare la variable OW (Onglet Week)
Dim I As Byte 'déclare la variable I (Incrément)
Dim K As Byte 'déclare la variable K (incrément)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set OC = Worksheets("Colored shifts") 'définit l'onglet OC
Set OW = Worksheets("Det. Week 1&2") 'définit l'onglet OW
OC.Range("B19").CurrentRegion.ClearContents 'efface les anciennes valeurs
TV = OW.Range("C1:C32") 'définit le tableau des valeurs TV
Set DEST = OC.Range("B19") 'définit la cellule de destination DEST
DEST.Value = TV(2, 1) 'récupère la date de C2 dans DEST
For I = 5 To UBound(TV, 1) 'boucle sur toutes les lignes I du tabeau des valeurs TV (en partant de la cinquième)
    Select Case I 'agit en fonction de I
        Case 5, 6, 9, 10, 13, 14, 17, 18, 21, 22, 31, 32 'cas d'horaire
            If TV(I, 1) <> "" Then 'si la donnée ligne I colonne 1 de TV n'est pas vide
                K = K + 1 'incrémente K
                ReDim Preserve TL(1 To K) 'redimensionne le tableau des lignes TL (K lignes)
                TL(K) = TV(I, 1) 'récupère l'horaire ligne I colonne 1 de TV dans la ligne K de TL
            End If 'fin de la condition
    End Select 'fin de l'action en fonction de K
Next I 'prochaine ligne de la boucle
'renvoie le tableau TL transposé dans la cellule redimensionné en-dessous de DEST
DEST.Offset(1, 0).Resize(K, 1).Value = Application.Transpose(TL)
End Sub
[Édition]
J'ai oublié de te dire, pour mettre du code formaté, utilise les balises prévues à Sète et fait (heu... A cet effet voulais-je dire !), Clique sur le symbole </> à coté de GIF.
 
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Bonsoir tout le monde, bonsoir @Caroaix, Bonsoir @Robert

Décidément je ne pédale pas assez vite ! mais j'ai pris le temps de boucler sur toutes les dates et de faire les barres colorées.
J'ai créé une feuille cible.

Voir le fichier joint

Pour l'appel :

Code:
Sub Transferer()
     Dim Wsh_S As Worksheet, Cible As Range
     Set Wsh_S = ThisWorkbook.Worksheets("Det. Week 1&2")
     Set Cible = ThisWorkbook.Worksheets("Cible").[_Cellule_Cible]
     Transfert Wsh_S, Cible
End Sub

Le code :
Enrichi (BBcode):
Sub Transfert(Wsh_S As Worksheet, Cible As Range)
  
     Const Lgn_Date = 2, First_Col = 3
     Dim Tb_Dic, Tb_Det_S, Tb_Res(), Valb
     Dim Lgn_Fin As Long, Nb_Lgn As Long, Col_Fin As Long, Nb_Col As Long, _
         NbCell As Long, Décal As Long, _
         Lgn As Long, col As Long, k As Long, Quart As Double
  
     Application.ScreenUpdating = False
  
     'Nettoyage
     With Cible
          Lgn_Fin = .EntireColumn.Cells(Parent.Rows.Count).End(xlUp).Row
          If Lgn_Fin >= .Row Then .Resize(Lgn_Fin - .Row + 1, 50).Clear
     End With
     'Dictionaire pour stocker les infos Shift de l'onglet "Tools" (nom, plages horaire, Couleur, motif)
     Dim MonDic As New Scripting.Dictionary
'     Dim MonDic As Object
'     Set MonDic = CreateObject("Scripting.Dictionary")
  
     With MonDic
          .CompareMode = 1
          .RemoveAll
     End With
     'tableau de l'onglet "Tools"
     Tb_Dic = ThisWorkbook.Worksheets("Tools").[A2:D17].Value
     For Lgn = 1 To UBound(Tb_Dic, 1)
          MonDic(Tb_Dic(Lgn, 1)) = Tb_Dic(Lgn, 2) & "|" & Format(Tb_Dic(Lgn, 2), "h:mm AM/PM") & "|" & Tb_Dic(Lgn, 3) & "|" & Format(Tb_Dic(Lgn, 3), "h:mm AM/PM") & "|" & Tb_Dic(Lgn, 4)
     Next Lgn
  
  
     'Limites à étudier
     Lgn_Fin = Wsh_S.Columns(First_Col).Cells(Wsh_S.Rows.Count).End(xlUp).Row
     Col_Fin = Wsh_S.Rows(Lgn_Date).Cells(Wsh_S.Columns.Count).End(xlToLeft).Column
     Nb_Col = Lgn_Fin - Lgn_Date + 1
     Nb_Lgn = Lgn_Fin - Lgn_Date + 1
  
     'Tableau des données
     Tb_Det_S = Wsh_S.Cells(Lgn_Date, First_Col).Resize(Nb_Lgn, Nb_Col).Value2 'Value2 pour pb d'interprétation des dates
     'Constitution des résultats
     k = 0
     For col = 1 To Nb_Col
          If IsDate(CDate(Tb_Det_S(1, col))) And Tb_Det_S(1, col) > 1 Then
               k = k + 1: ReDim Preserve Tb_Res(1 To k): Tb_Res(k) = Tb_Det_S(1, col)
               For Lgn = 2 To Nb_Lgn
                    If MonDic.Exists(Tb_Det_S(Lgn, col)) Then
                         If Tb_Det_S(Lgn, col) <> "Vacation" Then
                              k = k + 1: ReDim Preserve Tb_Res(1 To k): Tb_Res(k) = Tb_Det_S(Lgn, col)
                         End If
                    End If
               Next Lgn
          End If
     Next col
  
     'restitution des résultats
     Quart = CDbl(TimeValue("0:15:00")) 'pour calculer le nombre de cellules de la plage horaire
     With Cible.Resize(k)
          .Value = WorksheetFunction.Transpose(Tb_Res) 'Collage de toutes les valeurs
          .Borders.LineStyle = xlContinuous            'Bordures
          .NumberFormat = "yyyy-mm-dd"                 'format date
          Tb_Det_S = .Value                            'Relecture des résultats (avec les dates en tant que telles)
          'Coloration des dates
          For Lgn = 1 To k
               If IsDate(Tb_Det_S(Lgn, 1)) Then .Cells(Lgn).Interior.Color = 10092543 'si c'est une date mise en couleur
          Next
          'Barre de couleur correspondant au "Shift"
          For Lgn = 1 To k
               If MonDic.Exists(Tb_Res(Lgn)) Then
                    Valb = Split(MonDic(Tb_Res(Lgn)), "|")                                  'Récupération des données pour ce shift
                    NbCell = Int((TimeValue(Valb(3)) - TimeValue(Valb(1))) / Quart)       'Nombre de quarts d'heures = nombre de cellule de la barre
                    Décal = CInt((TimeValue(Valb(1)) - TimeValue("9:45 Am")) / Quart) + 1 'Décalage de la barre
                    With .Cells(Lgn).Offset(0, Décal)
                         .Value = "x"                                                      'Valeur x pour l'affichage du format texte
                         .NumberFormat = ";;;""" & Valb(1) & """* """ & Valb(3) & """"     'Format spécial "Début          Fin" sur la barre
                         .Resize(1, NbCell).Merge                                          'Fusionner les cellules de la barre
                         .Interior.Color = Valb(4)                                         'Couleur de fond
                         If UBound(Valb) > 4 Then
                              .Interior.PatternColor = Valb(5)                               'Si motif, couleur du motif
                              .Interior.Pattern = Valb(6)                                    'si motif, motif choisi
                         End If
                         .MergeArea.Borders.LineStyle = xlContinuous                        'Bordures autour de la barre
                    End With
               End If
            
          Next Lgn
     End With
     Application.ScreenUpdating = True

End Sub

Amicalement
Alain
 

Pièces jointes

  • Exemple pour planning macro.xlsm
    53.6 KB · Affichages: 6
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Re ...
PS : j'ai remarqué un écart dans les fonctions
=SI(ESTVIDE(C15);"";RECHERCHEV(C15;Tools!$A$1:$C$16;2;FAUX))​
et​
=SI(ESTVIDE(C15);"";RECHERCHEV(C15;Tools!$A$1:$C$16;3;FAUX))​
que j'ai remplacé par
=SI(ESTVIDE(C15);"";RECHERCHEV(C15;Tools!$A$2:$C$17;2;FAUX))​
et​
=SI(ESTVIDE(C15);"";RECHERCHEV(C15;Tools!$A$2:$C$17;3;FAUX))​
Alain
Corrections faites dans le fichier joint
 

Pièces jointes

  • Exemple pour planning macro.xlsm
    53.6 KB · Affichages: 4

Caroaix

XLDnaute Nouveau
Bonjour,

Là vous allez vraiment trouvé que j'abuse mais j'ai relevé divers problèmes.
Sur l'onglet cible, certaines barres d'horaires ne correspondent pas à la barre d'entête. Je les ai matérialisé avec un carré marron. Egalement le 9:45.
Autre chose, est-il possible de voir apparaitre les shifts dans l'onglet cible dans le même ordre que dans l'onglet Tools. Comme cela il y a une chronologie entre ceux du matin, du milieu et du soir.
Je n'ose pas aller bidouiller dans le code car c'est super et je ne voudrais pas faire de bêtise.
Je rejoins le fichier avec les cellules identifiées
Encore un immense merci
 

Pièces jointes

  • Exemple pour planning macro retour forum.xlsm
    57.1 KB · Affichages: 3

Caroaix

XLDnaute Nouveau
Bonjour,

J'ai réussi à aligner les cellules sur les quart d'heure par contre quatre shifts ne correspondent pas. Les autres sont nickels. J'ai regardé dans l'onglet tools si ce n'était pas un problème d'espace ou de format. Mais non. Je ne comprend pas le pourquoi ? Je les ai identifiées avec une cellule marron. Ce sont les premiers dans l'onglet cible.
Aussi serait-il possible d'ordonnancer les shifts sous chaque date comme dans l'onglet tools pour plus de lisibilité ? j'ai regardé avec rank mais je sèche.
Je rejoins le fichier.
Merci d'avance
 

Pièces jointes

  • Exemple pour planning macro retour forum.xlsm
    57.4 KB · Affichages: 2

AtTheOne

XLDnaute Accro
Supporter XLD
Sur l'onglet cible, certaines barres d'horaires ne correspondent pas à la barre d'entête. Je les ai matérialisé avec un carré marron. Egalement le 9:45.
En fait l'heure indiquer dans la cellule d'entête est l'heure de fin de la cellule (voir l'annotation) donc les heures de début étaient bonnes
Pour les heures de fin, il s'agissait d'un problème avec la fonction Int() qui lorsque le calcul n'était pas un entier, tronquait la valeur calculer, j'ai remplacer par Round() avec 0 décimales.
Enrichi (BBcode):
NbCell = Int((TimeValue(Valb(3)) - TimeValue(Valb(1))) / Quart)      'Nombre de quarts d'heures = nombre de cellule de la barre
REMPLACER PAR
NbCell = Round((TimeValue(Valb(3)) - TimeValue(Valb(1))) / Quart, 0)      'Nombre de quarts d'heures = nombre de cellule de la barre

Pour l'ordre, je regarde
Amicalement
Alain
 

Pièces jointes

  • Exemple pour planning macro.xlsm
    57.8 KB · Affichages: 6
Dernière édition:

AtTheOne

XLDnaute Accro
Supporter XLD
Re ...
On s'est croisé je crois ...
Je ne ferai pas ta modif, voir mes explications dans le post #9.
Pour le pourquoi, je te donne également l'explication dans le post #9
Je regarde l'ordre dès que je le peux.
Amaicalement
Alain
 

Robert

XLDnaute Barbatruc
Repose en paix
Bonsoir le fil, bonsoir le forum,

Désolé mais mon PC a rendu l'âme et je n'ai pu revenir sur ce post. Je remercie Alain qui a pris le relais et qui a assuré grave...
 

Discussions similaires

Réponses
9
Affichages
342
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…