Extraction d'enregistrements dans un onglet

**thierry78420** · 04/10/2021, 12h30

Bonjour à Tous,

N'ayant aucune compétence en programmation, je me permets de faire appel à des spécialistes et professionnelles.

Je vous ai mis une impression ecran de mon tableau qui je pense s'exprimera beaucoup mieux que moi en visuel.

L'objectif de ce projet est :

Par le biais d'une variable "D3" (Nombre de Jours), et Date de Fin "N8" ces deux cellules combinées me donnent une date de transfert "T8".

Je souhaiterai, soit à l'ouverture du classeur ou alors par l'intermédiaire d'un bouton transférer les dates de transfert "T8" dans un autre onglet (intitulé "Archive"). si la date du jour est égale à la date de transfert je peux transférer l'enregistrement.

J'espère avoir été clair dans ma demarche mais je reste entièrement disponible pour repondre à vos questions.

Je tiens à remercier tous ceux qui liront ma demande et m'aideront à concrétiser mon projet.

Cdlt, Thierry

**BENNASR** · 04/10/2021, 13h26

Bonjour
1 : je propose de ne pas supprimer la ligne à la date de l'échéance et l'envoyer dans l'onglet "ARCHIVE" mais d'ajouter la mention "archivé" devant la ligne appropriée ;
tu peux bien sur filtrer tes données et ne pas afficher que les lignes ou la colonne U est vide (en cas de besoin ultérieur qd tu cherche à user de toutes les données même archivées)
si ça te convient je propose un bout de code a tester sur une copie de ton fichier pour munir contre tous risque de perte de données :
faire attention au nom des onglets : à adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub testt()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim f2 As Worksheet
Set F1 = Sheets("IP")
Set f2 = Sheets("ARCHIVE I.P CLOTURES")
Dim i As Long
Dim derlig As Long
derlig = F1.Range("T" & Rows.Count).End(xlUp).Row
For i = 8 To derlig
If F1.Cells(i, "U") = "" And Date - F1.Cells(i, "T") >= 0 Then
F1.Cells(i, "U") = "ARCHIVEE"
lig = f2.Range("A" & Rows.Count).End(xlUp).Row + 1
F1.Range(F1.Cells(i, "A"), F1.Cells(i, "O")).Copy
f2.Cells(lig, "A").PasteSpecial Paste:=xlPasteValues
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

**thierry78420** · 04/10/2021, 14h53

Merci beaucoup,

J'accepte totalement le terme "ARCHIVEE"

j'ai copié votre petit langage sur ma feuille ("IP") VBA

J'ai refermé mon dossier puis relancé mais rien ne se produit?

J'ai certainement rien compris a ce que vous vouliez que je fasse. le enregistrement ne bouge pas , aucun message d'erreur .

encore merci pour votre rapidité

Thierry

**BENNASR** · 04/10/2021, 15h19

pour gagner du temps m'envoyer un fichier test avec deux lignes de données non confid
mon fichier pour test

**thierry78420** · 05/10/2021, 11h03

Envoyé par BENNASR

pour gagner du temps m'envoyer un fichier test avec deux lignes de données non confid
mon fichier pour test

UN GRAND MERCI POUR VOTRE AIDE

Cdlt, Thierry

**BENNASR** · 05/10/2021, 11h37

à tester

**thierry78420** · 05/10/2021, 13h12

Envoyé par BENNASR

à tester

Merci Beaucoup de consacrer votre temps sur mon projet.(Bravo, bravo)

Est ce possible de ne plus mettre "Archivée" en "U" mais plutôt de supprimer les enregistrements transferés de IP vers Archive

L'objectif étant d'avoir moins enregistrement dans IP et surtout d'avoir un œil rapide sur les dossiers patients.

Mille fois merci pour votre générosité.

Cdlt,Thierry

**BENNASR** · 05/10/2021, 14h34

pour simplifier les chose j'ai modifié la feuille de l'archivage pour commencer de la colonne B au lieu de A comme l'onglet de tes données
le code coupe et colle les données dont la date est égale à aujourd'hui OU INTERIEURE à aujourd'hui
à tester sur une copie de ton fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Extraction()
 
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim i As Long
Dim derlig As Long
Application.ScreenUpdating = False
Set F1 = Sheets("IP")
Set f2 = Sheets("Archive I.P Clôturées")
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
For i = derlig To 8 Step -1
If Date - CDate(F1.Cells(i, "T")) >= 0 Then
lig = f2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(i, 1).EntireRow.Copy f2.Cells(lig, 1)
F1.Cells(i, 1).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub

**thierry78420** · 05/10/2021, 20h49

Tout d'abord je ne sais pas comment vous remerciez mais le travail que vous avez effectué correspondant totalement à mes attentes.
Félicitations BENNASR

Je souhaiterai mettre un message pour m'avertir du nombre de d'enregistrement transferé dans Archive
Dois je le mettre avant la fonction delete?

D'autre part, je me suis posé la question après cette joie, apres avoir mis toutes les colonnes au bonnes dimensions,
Pourquoi ne pas automatiser le transfert des enregistrements a l'ouverture du dossier? Est ce quelque chose de compliqué à metttre en oeuvre ?

Encore un grand merci à vous, fier d'etre tombé sur vous pour résoudre mon problème.

Cdlt Thierry

**BENNASR** · 06/10/2021, 09h37

Bonjour
1 : ajouter un compteur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Extraction()
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim i As Long
Dim derlig As Long
Application.ScreenUpdating = False
Set F1 = Sheets("IP")
Set f2 = Sheets("Archive I.P Clôturées")
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
compteur = 0
For i = derlig To 8 Step -1
If Date - CDate(F1.Cells(i, "T")) >= 0 Then
lig = f2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(i, 1).EntireRow.Copy f2.Cells(lig, 1)
F1.Cells(i, 1).EntireRow.Delete
compteur = compteur + 1
End If
Next i
MsgBox (compteur & " dossiers ont été archivés")
Application.ScreenUpdating = True
End Sub

2- appeler la procédure à l'ouverture du classeur :
dans l'éditeur VBA / ThisWorkbook/dans l’événement workbook_open :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Workbook_Open()
Call Extraction
End Sub

**thierry78420** · 06/10/2021, 21h40

Bonsoir BENNASR,

Juste le compteur ne fonctionne pas comme je le souhaitais.
Mon point de vue etait le suivant: Savoir combien de dossier lors de la demande ont ete tranferés dans l'onglet "Archive".
Aujourd'hui le msg que je recois est le suivant : 1dossiers ont ete archivés.

je testé le call Génial encore merci de votre rapidité et gentillesse concernant mon projet

Bonne soirée BENNASR

Cdlt, Thierry

**BENNASR** · 07/10/2021, 11h59

bonjour
le compteur te donne le nombre des dossiers qui ont été archivés ce jour même et non pas le total des dossiers archivés
si tu cherches à connaitre le nombre total des dossiers archivés :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Extraction()
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim i As Long
Dim derlig As Long
Application.ScreenUpdating = False
Set F1 = Sheets("IP")
Set f2 = Sheets("Archive I.P Clôturées")
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
For i = derlig To 8 Step -1
If Date - CDate(F1.Cells(i, "T")) >= 0 Then
lig = f2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(i, 1).EntireRow.Copy f2.Cells(lig, 1)
F1.Cells(i, 1).EntireRow.Delete
End If
Next i
j = f2.Range("B" & Rows.Count).End(xlUp).Row - 2
MsgBox (j & " dossiers ont été archivés")
Application.ScreenUpdating = True
End Sub

**thierry78420** · 07/10/2021, 12h55

Bonjour et merci BENNASR,

En faite, je me suis mal exprimé sur ma demande, ce que je recherche c'est de connaitre le nombre d'enregistrements transférés de "IP" à "Archive" lorsqu'il y a une extraction.

Cdlt, Thierry

**BENNASR** · 07/10/2021, 14h16

tester proposition 1 alors
normalement ça te donne le nombre des archivés chaque jour
tester avec un exemple de qq ligne et si ça donne pas le bon résultat merci de joindre cette exemple pour vérification :
selon tes propos vous avez reçu le message : "1dossiers ont ete archivés." parce que cette journée vous n'avez qu'un seul dossier archivé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Extraction()
Dim F1 As Worksheet
Dim f2 As Worksheet
Dim i As Long
Dim derlig As Long
Application.ScreenUpdating = False
Set F1 = Sheets("IP")
Set f2 = Sheets("Archive I.P Clôturées")
derlig = F1.Range("B" & Rows.Count).End(xlUp).Row
compteur = 0
For i = derlig To 8 Step -1
If Date - CDate(F1.Cells(i, "T")) >= 0 Then
lig = f2.Range("B" & Rows.Count).End(xlUp).Row + 1
F1.Cells(i, 1).EntireRow.Copy f2.Cells(lig, 1)
F1.Cells(i, 1).EntireRow.Delete
compteur = compteur + 1
End If
Next i
MsgBox (compteur & " dossiers ont été archivés")
Application.ScreenUpdating = True
End Sub

**thierry78420** · 07/10/2021, 14h40

6 enregistrement créer dont 3 selectionnés à la date d'aujourd'hui, message recu "1 dossier ont été archivé"

Cdlt

**BENNASR** · 07/10/2021, 14h57

je recois 3 !!!!

**thierry78420** · 07/10/2021, 16h13

Envoyé par BENNASR

je recois 3 !!!!

Ok cela fonctionne pour vous.

A chaque fois que je lance le dossier il me dit qu'il a sauvegardé 3 dossiers - Impeccable

Par contre me concernant cela ne fonctionne pas, la seul difference entre votre solution et la mienne c'est que moi j'ai une formule dans ma cellule de transfert et vous votre
date est saisie manuellement. Est ce cela le pb?

Cdlt

**BENNASR** · 07/10/2021, 16h21

j'ai testé avec une formule et ça fonctionne (teste chez toi sur ce fichier et tu va voir que ça fonctionne)
vérifier chez vous si non enregistré un fichier test avec qq lignes non confid et qui donne faux résutat

**thierry78420** · 07/10/2021, 21h36

Envoyé par BENNASR

j'ai testé avec une formule et ça fonctionne (teste chez toi sur ce fichier et tu va voir que ça fonctionne)
vérifier chez vous si non enregistré un fichier test avec qq lignes non confid et qui donne faux résutat

Bonsoir,

J'ai fais un clear de mon tableau puis rajouter des ecritures en test ; il m'annonce bien à chaque fois le nombre de dossier qui sont archivés.

Mais il me dit pas combien de nouveau dossier qu'il envoie dès l'ouverture du classeur.

Si la veille j'avais 5 dossiers d'archivés et qu'aujourd'hui j'ai un dossier de transferé , il va m'envoyer comme message vous avez 6 dossiers d'archivés

Moi, j'aimerai avoir vous avez un dossier ou un enregistrement qui a ete transferé.

Cdlt, BENNASR

**BENNASR** · 08/10/2021, 09h00

Si la veille j'avais 5 dossiers d'archivés et qu'aujourd'hui j'ai un dossier de transferé , il va m'envoyer comme message vous avez 6 dossiers d'archivés

Si la veille tu as déjà ouvert ton dossier donc la veille tu aura un message "5 dossiers archivés" et aujourd'hui qd tu vas ouvrir ton dossier tu aura message 01 dossier archivé mais si la veille tu n'as pas ouvert ton dossier donc les 5 dossiers ne sont pas déja archivés ; aujourd'hui le code va archivé tous les dossiers échus et va envoyer un message : "6 dossiers archivés puisque le code ne prends pas en compte la date d'aujourd'hui mas tous les dossiers ayant une date EGALE ou INFERIEURE à aujourd'hui
Autre piste : au lieu d'un compteur tu peux simplement chercher la dernière ligne de la feuille archivage avant l’exécution de la boucle et la dernière ligne après la boucle et 1-2 tu aura la nombre des lignes transférés
pour chercher la dernière ligne non vide

Extraction d'enregistrements dans un onglet [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager