Test sur 2 cellules - si vrai > copie cellules sur autre feuille au MEME endroit

[TgR]

Bonjour à tous,

Je suis en train d'essayer de faire une petite macro qui me permettrait de gagner un certains temps. Je vous explique (voir PJ).

Ce tableau est à mettre à jour tous les mois et cette mise à jour s'effectue en fonction de la colonne H3 (intitulée date_s).

Donc à partir de la cellule H4 (là ou commence les noms de patients) je commence à faire ma mise à jour. Cette mise à jour s'effectue de la manière suivante (je fais un exemple pour les cellules H4 à H7).

Cellule H4 vide mais aucun patient enregistré (nom prénom, cellules d5 - e5) => je ne copie rien
Cellule H5 pleine => je ne copie rien
Cellule H6 vide et aucun patient enregistré => je ne copie rien

Cellule H7 vide ET patient enregistré => JE COPIE cellules C7-D7-E7-F7 | Je sélectionne le mois de Février et je colle ces cellules au même endroit (donc en position 7)

J'ai tenté de faire une petite macro pour automatiser tout ça. J'ai bien conscience que c'est quelque chose d'assez simple pour les connaisseurs mais... je bloque !

j'aimerais créer un fenêtre "MAJ" dans lequel il y aurait une liste déroulante permettant de choisir le mois à mettre à jour avec un bouton "lancer mise à jour" qui ferait la manipulation que je viens d'expliquer...


Serait-il possible dans un premier temps d'avoir seulement des indices (car j'aimerais réaliser cette petite macro tout seul).

Les points sur lesquels je bloque :

- Je me demande si je dois créer un tableau dans mon code (puisque le tableau est fixe et toujours le même pour tous les mois)
- Ensuite je me demande comment copier au même endroit sur une autre feuille (j'imagine que quelque chose comme Sheets("JANVIER").Range("C7", etc..) serait une solution mais si j'écris ce code on en arrive à un autre problème
- Comment passer à la cellule d'après avoir testé la précédente.


En espérant avoir été assez clair.

Je vous remercie par avance.

 

[Robert]

Re : Test sur 2 cellules - si vrai > copie cellules sur autre feuille au MEME endroit

Bonjour Tgr, bonjour le forum,

Pour que la macro agisse ligne après ligne il te faut faire une boucle

For Each cel In Sheets(ni).Range("H4:H24")
    'condition
Next cel

En pièce jointe la solution complète dans le Module5 de ton fichier modifié :

 

[TgR]

Re : Test sur 2 cellules - si vrai > copie cellules sur autre feuille au MEME endroit

Bonjour Robert,

Merci pour ta réponse !

J'aimerais savoir s'il n'est pas possible d'accélérer le processus en déclarant un tableau ? En effet, mon tableau réel fait 423 lignes et j'ai cru comprendre en lisant quelques tutos qu'en déclarant des tableaux le temps d'exécution se réduit énormément.

Actuellement le temps d'exécution de la macro est plutôt long. Si ce n'est pas possible ça m'ira très bien mais j'aimerais juste savoir s'il est possible d'accélérer tout ça. (ça me permettra de comprendre comment fonctionne les tableaux comme ça !)

Merci beaucoup !

TgR

 

[Robert]

Re : Test sur 2 cellules - si vrai > copie cellules sur autre feuille au MEME endroit

Bonjour TgR, bonjour le forum,

La même avec un tableau... :

Sub macro1()
Dim ni As Byte 'déclare la variable ni (Numéro Index)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim tbl As Variant 'déclare le tableau tbl
Dim i As Integer 'déclare la variable i (Incrément)

ni = ActiveSheet.Index 'définit le numéro d'index ni
dl = Sheets(ni).Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 2 (=B)
tbl = Sheets(ni).Range("D4:H" & dl).Value 'définit le tableau tbl
For i = 1 To UBound(tbl, 1) 'boucle sur toutes les lignes du tableau tbl
    'condition : si la cellule en H est vide et si l'une des cellules en D ou E n'est pas vide
    If tbl(i, 5) = "" And tbl(i, 2) <> "" Or tbl(i, 2) <> "" Then
        'copie la plage des cellule en ligne i+3 colonnes C à f et la colle dans l'onglet suivant
        Sheets(ni).Cells(i + 3, 3).Resize(1, 4).Copy Sheets(ni + 1).Cells(i + 3, 3)
    End If 'fin de la condition
Next i 'prochaine ligne du tableau
End Sub