Modification mise à jour de classeurs en VBA
Bonsoir à tous,
J'ai récupéré le travail d'un collègue nous ayant quitté. Des données sont puisées dans différents classeurs et transposé dans d'autres par l'entre-mise d'un troisième classeur de style matrice. Les données puisées servent à faire des mises à jour et concernent 5 services (DITSADP, SM, SAPA, Jeunesse et services courants).
J'ai besoin de conserver seulement deux de ces services soient le service jeunesse et le service SM. J'ai tenté de rendre le code inactif pour ces services mais en vain. Je vous mets le code complet du fichier qui sert à faire les mises à jour. Une personne ici qui peut m'aider dans ce code qui m'apparait complexe.
Merci de m'aider à y voir plus clair dans ce code.
Sub Trente_Jours()
Dim X As Long
Dim Y As Long
Dim feuille As Worksheet
'Dim WK As Workbook
Dim wk2 As Workbook
Dim Code_Programme As String
Dim Plage_Recherche As Range
Dim Pourcentage_Add As Range
Dim Délai_Pourcentage As Variant
Set WK_Resultat = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse Jeunesse.xlsx")
'Set Wk_resultat = Workbooks("INV Fiche synthèse Jeunesse.xlsx")
For Y = 3 To 9
'Ouvrir le fichier source
Base = WK_Resultat.Worksheets("% <30 jours").Cells(10, Y).Value
Set wk2 = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\Prise en charge\" & Base & "_Pourcentage pris en charge 30 jours_Jeunesse.xlsx")
wk2.Worksheets(1).Range("A:H").UnMerge '.UsedRange.SpecialCells(xlCellTypeLastCell)
'Ajuster ici si modification sous programme
For X = 12 To 56
'Boucle sur les codes sous-programme
Set Plage_Recherche = wk2.Worksheets(1).Columns(1)
Code_Programme = WK_Resultat.Worksheets("% <30 jours").Cells(X, 1).Value
Set Pourcentage_Add = Plage_Recherche.Cells.Find(what:=Code_Programme, LookIn:=xlValues, LookAt:=xlWhole, searchdirection:=xlNext, SearchOrder:=xlByColumns)
'Si un résultat est trouvé
If Not Pourcentage_Add Is Nothing Then
délai = Pourcentage_Add.Offset(0, 3).Value
'Valider si mmoins de trente jours
If délai = "Moins de 30 jours" Then
'Ajout 2018-05-10 car une colonne de moins en P1
Délai_Pourcentage = Pourcentage_Add.Offset(0, 6).Value
If IsEmpty(Délai_Pourcentage) Then Délai_Pourcentage = Pourcentage_Add.Offset(0, 5).Value
'Modification car une ligne vide, on se base maintenant sur le texte
ElseIf délai = "30 jours et plus" Then
Délai_Pourcentage = Pourcentage_Add.Offset(0, 6).Value
If IsEmpty(Délai_Pourcentage) Then Délai_Pourcentage = Pourcentage_Add.Offset(0, 5).Value
If Not Délai_Pourcentage = "" Then Délai_Pourcentage = 1 - Délai_Pourcentage
'' Else
'' Valider si un résultat moins de trente jour est inscrit à la ligne en desssous pour le m^me sous programme
'' délai = Pourcentage_Add.Offset(1, 2).Value
'' If délai = "" Then
'' Délai_Pourcentage = Pourcentage_Add.Offset(1, 6).Value
'' If IsEmpty(Délai_Pourcentage) Then Délai_Pourcentage = Pourcentage_Add.Offset(1, 5).Value
'' Si les deux conditons sont non résultat = 0%
'' Else
'' Délai_Pourcentage = 0
'End If
End If
Else
Délai_Pourcentage = "#N/A"
End If
WK_Resultat.Worksheets("% <30 jours").Cells(X, Y) = Délai_Pourcentage
Délai_Pourcentage = ""
Next X
wk2.Close False
Next Y
WK_Resultat.Save
End Sub
Sub Trente_Jours_SM()
Dim X As Long
Dim Y As Long
Dim feuille As Worksheet
'Dim WK As Workbook
Dim wk2 As Workbook
Dim Code_Programme As String
Dim Plage_Recherche As Range
Dim Pourcentage_Add As Range
Dim Délai_Pourcentage As Variant
'Set WK = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse SMDPSG.xlsx")
'Set WK_Resultat = Workbooks("INV Fiche synthèse SMDPSG.xlsx")
For Y = 3 To 9
'Ouvrir le fichier source
Base = WK_Resultat.Worksheets("% <30 jours").Cells(10, Y).Value
Set wk2 = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\Prise en charge\" & Base & "_Pourcentage pris en charge 30 jours_SMDPSGA.xlsx")
wk2.Worksheets(1).Range("A:G").UnMerge '.UsedRange.SpecialCells(xlCellTypeLastCell)
If IsEmpty(wk2.Worksheets(1).Range("D6")) = True Then wk2.Worksheets(1).Cells(6, 4).EntireRow.Delete
'Ajuster ici si ajout de sous-programme
For X = 12 To 70
'Boucle sur les codes sous-programme
Set Plage_Recherche = wk2.Worksheets(1).Columns(1)
Code_Programme = WK_Resultat.Worksheets("% <30 jours").Cells(X, 1).Value
Set Pourcentage_Add = Plage_Recherche.Cells.Find(what:=Code_Programme, LookIn:=xlValues, LookAt:=xlWhole, searchdirection:=xlNext, SearchOrder:=xlByColumns)
'Si un résultat est trouvé
If Not Pourcentage_Add Is Nothing Then
délai = Pourcentage_Add.Offset(0, 3).Value
'Valider si mmoins de trente jours
If délai = "Moins de 30 jours" Then
'Ajout 2018-05-10 car une colonne de moins en P1
Délai_Pourcentage = Pourcentage_Add.Offset(0, 5).Value
If IsEmpty(Délai_Pourcentage) Then Délai_Pourcentage = Pourcentage_Add.Offset(0, 6).Value
Else
'Valider si un résultat moins de trente jour est inscrit à la ligne en desssous pour le m^me sous programme
délai = Pourcentage_Add.Offset(1, 2).Value
If délai = "" Then
Délai_Pourcentage = Pourcentage_Add.Offset(1, 5).Value
If IsEmpty(Délai_Pourcentage) Then Délai_Pourcentage = Pourcentage_Add.Offset(1, 6).Value
'Si les deux conditons sont non résultat = 0%
Else
Délai_Pourcentage = 0
End If
End If
Else
Délai_Pourcentage = "#N/A"
End If
WK_Resultat.Worksheets("% <30 jours").Cells(X, Y) = Délai_Pourcentage
Next X
wk2.Close False
Next Y
WK_Resultat.Save
End Sub
Sub Trente_Jours_SAPA()
'non corrigé 2020-11-12
Dim X As Long
Dim Y As Long
Dim feuille As Worksheet
'Dim WK As Workbook
Dim wk2 As Workbook
Dim Code_Programme As String
Dim Plage_Recherche As Range
Dim Pourcentage_Add As Range
Dim Délai_Pourcentage As Variant
'Set Wk_resultat = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse SMDPSG.xlsx")
Set WK_Resultat = Workbooks("INV Fiche synthèse SAPA.xlsx")
For Y = 3 To 9
'Ouvrir le fichier source
Base = WK_Resultat.Worksheets("% <30 jours").Cells(10, Y).Value
Set wk2 = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\Prise en charge\" & Base & "_Pourcentage pris en charge 30 jours_SAPA.xlsx")
wk2.Worksheets(1).Range("A:G").UnMerge '.UsedRange.SpecialCells(xlCellTypeLastCell)
For X = 12 To 35
'Boucle sur les codes sous-programme
Set Plage_Recherche = wk2.Worksheets(1).Columns(1)
Code_Programme = WK_Resultat.Worksheets("% <30 jours").Cells(X, 1).Value
Set Pourcentage_Add = Plage_Recherche.Cells.Find(what:=Code_Programme, LookIn:=xlValues, LookAt:=xlWhole, searchdirection:=xlNext, SearchOrder:=xlByColumns)
'Si un résultat est trouvé
If Not Pourcentage_Add Is Nothing Then
délai = Pourcentage_Add.Offset(0, 4).Value
'Valider si mmoins de trente jours
If délai = "Moins de 30 jours" Then
Délai_Pourcentage = Pourcentage_Add.Offset(0, 7).Value
Else
'Valider si un résultat moins de trente jour est inscrit à la ligne en desssous pour le m^me sous programme
délai = Pourcentage_Add.Offset(1, 2).Value
If délai = "" Then
Délai_Pourcentage = Pourcentage_Add.Offset(1, 7).Value
'Si les deux conditons sont non résultat = 0%
Else
Délai_Pourcentage = 0
End If
End If
Else
Délai_Pourcentage = "#N/A"
End If
WK_Resultat.Worksheets("% <30 jours").Cells(X, Y) = Délai_Pourcentage
Next X
wk2.Close False
Next Y
WK_Resultat.Save
End SubBonjour
Des données sont puisées dans différents classeurs et transposé dans d'autres par l'entre-mise d'un troisième classeur de style matrice. Les données puisées servent à faire des mises à jour et concernent 5 services (DITSADP, SM, SAPA, Jeunesse et services courants).
Waouh.... interaction entre 3 fichiers et d'autres .... cela commence bien là
J'ai besoin de conserver seulement deux de ces services soient le service jeunesse et le service SM. J'ai tenté de rendre le code inactif pour ces services mais en vain. Je vous mets le code complet du fichier qui sert à faire les mises à jour. Une personne ici qui peut m'aider dans ce code qui m'apparait complexe.
Que voulez-vous savoir au niveau code ?
Sans voir le fichier ce n'est pas simple d'autant que si je comprends vous naviguez entre plusieurs fichiers.
1. Un truc gênant sont les espaces et accents dans les noms de feuille et dossier dans le répertoire. A éviter.
2. voici un début d'analyse dans le code Trente Jours
- WK_Resultat : concerne le fichier INV Fiche synthèse Jeunesse.xlsx
- base : concerne les données du fichier INV Fiche synthèse Jeunesse.xlsx, feuille "% <30 jours", cellules en ligne 10, colonnes de 3 à 9 (variable y)
- wk2 concerne le nom de fichier depuis la valeur de la variable BASE ci-avant et "_Pourcentage pris en charge 30 jours_Jeunesse.xlsx"
- la ligne wk2.Worksheets(1).Range("A:H").UnMerge concerne une défusion des colonnes (les fusions VBA aime pas et sont toujours à éviter avec ou sans VBA d'ailleurs)
- For Y = 3 To 9 : boucle sur les colonnes 3 à 9
- For X = 12 To 56 : boucle sur les lignes 12 à 56 dans les colonnes 3 à 9 (variable Y)
Voilà une premier jet car après cela se complique un peu
Merci Dan.
Je vais poursuivre mon analyse de code avec l'information que vous m'avez transmises. En regard de ce que j'ai besoin de faire pour m'approprier le dossier, j'ai besoin de conserver seulement les données en sm et jeunesse. Lorsque je clique sur le bouton du classeur 1234go, il migre les données vers deux classeurs que je vais renommer. Dans l'instant, il y a plusieurs données d'autres services qui me sont inutiles. J'aimerais annuler le code pour la ditsadp, sapa et services courants. J'ai tenté d'annuler en ajoutant l'apostrophe mais cela ne fonctionne pas.
J'ajoute le fichier.
re
J'ai tenté d'annuler en ajoutant l'apostrophe mais cela ne fonctionne pas.
C'est la bonne méthode. Qu'est -ce qui ne fonctionne pas ?
J'aimerais annuler le code pour la ditsadp, sapa et services courants.
je ne vois pas de code ditsadp ni de sapa dans le fichier ... quid ?
Services courants c'est la Sub Demandes_Services_Courants() dont vous parlez ?
Je découvre le fichier donc merci d'être progressif et de commencer par le début des codes dans vos explications.
Autre point : votre fichier fonctionne sur windows ou sur MAC ? Cette question parce que si je regarde les répertoires mentionnés on voit ceci dans vos codes -_>
Comme vous voyez les accents sont modifiés...
oui je travaille sur Windows. Notre collègue, qui a monté le code nous a quitté. Je ne comprends pas bien son travail. J'essaie de modifier le code en annulant la commande pour les Sub Demandes_Services_Courants() SAPA et ditsadp mais il génère tout de même un fichier alors pour ma part je suis à me demander ce que je ne fait pas de bien ou alors tout reprendre ?
J'essaie de modifier le code en annulant la commande pour les Sub Demandes_Services_Courants() SAPA et ditsadp
Il faudrait que je comprenne déjà de quel bouton vous partez ?
Il y a 11 modules dans votre fichier avec autant de codes, là je ne sais pas vous aider si vous ne m'expliquez pas d'où vous partez. Soyez progressif sans quoi on ne va jamais y arriver
bien sûr. J'ai tenté d'annuler les sub dont on parles dans le module prise en charge. Peut-être serait-il opportun d'annuler également les modules demandes sapa et services courants ? Je n'en suis pas moins certaines. Je ne suis sûr de rien dans ce fichier.
Merci pour votre aide
Dans mon post précédent, je vous ai posé une question à laquelle vous ne répondez pas.
Je ne comprends rien à l'utilisation de votre fichier donc si vous ne répondez pas à la question posée on ne sait pas avancer.
Bonsoir Dan,
J'ai tenté des modifications ce jour et je ne suis toujours pas en mesure d'assurer un changement concernant les services. Personne ici ne peut m'indiquer les dénouements possibles avec les fichiers.
Lorsque je sélectionne MAJ Jeunesse dans le fichier classeur 1234go je génère les données des onglets de ce tableau que j'ai joins. Ensuite je vais travailler les données. J'ai besoin de concerver seulement les données Jeunesse et SM.
Bonsoir
C'est un peu une usine à gaz là avec tous ces codes mais bon il a bien compartimenté les modules. Quoi qu'il en soit, faites comme ceci :
1. Si vous ne l'avez pas fait, pour les modifications faites d'abord une copie de votre fichier ce sera mieux je pense
2. sur base de votre dernier post, seuls les boutons MJ-SM et MJ-jeunesse peuvent rester en place. Là vous pouvez supprimer les autres boutons pour ne garder que ces deux là.
3. ensuite :
- Allez dans le module MAJ
- vous pouvez désactiver tous les codes sauf les deux codes Sub MAJ_SM() et Sub MAJ_Jeunesse()
Une fois les codes désactivés, je vous conseille de les déplacer plus bas après les deux codes ci-dessus
Attention laissez bien la ligne Public WK_Resultat As Workbook où elle se trouve
Une fois fait on peut regarder ce qui sert encore dans les autres modules et avancer pas à pas
Bonjour Dan,
J'avoue être bien mélanger dans tout ces codes. Je vais m'y mettre un peu plus tard je reviens avec un suivi.
Merci !
Bonjour
J'avoue être bien mélanger dans tout ces codes.
Déjà suivez pas à pas ce que je vous ai donné dans mon post précédent
Après je vous donnerai les codes à conserver
Bonsoir Dan,
Le tout fonctionne à merveille. J'obtient les résultats escomptés en SM et Jeunesse. Je vais développer afin de voir ce que je dois converser ou non dans les autres modules...
Je suis encore à regarder le classeur. Si on va dans le même sens que ce que vous avez proposé et si je désire conserver seulement les données de l'onglet du suivi étroit je procèrerais de la même façon, c-a-dire que je vais désactiver tous les autres codes ...
À votre avis...
Merci
Bonjour,
si je désire conserver seulement les données de l'onglet du suivi étroit
Heu oui, mais votre dernier fichier posté ne contient aucun code. Pas facile de s'y retrouver
Donc supprimez déjà les codes mentionnés ci-dessous et regardez si cela fonctionne déjà avant de passer à la suppression de feuilles dans le deuxième fichier
Voici les codes que vous pouvez désactiver ou supprimer :
Dans le module Prise en charge --> Sub Trente_Jours_SAPA()
Dans le module Ouvrir les fichiers --> Sub ouvrir_Fichier_SAPA()
Dans le module Demandes_SAPA_Module --> Sub Demandes_SAPA()
dans le module1 --> Sub Demandes_Jeunesse()
Dans le module Copier_Coller_Feuille --> Sub Copier_Coller_DI_TSA_DP() et Sub Copier_Coller_SAPA() et Sub Copier_Coller_SC()
Dans le module Demande_Services_Courants --> Sub Demandes_Services_Courants()
dans le module Fermer_LEs_Ficher --> Sub FERMER_Fichier_SAPA()
Dans le module Groupe --> Sub Groupe_DI_TSA_DP()
Pour tous les modules où il n'y a qu'un seul code et que ce code est à supprimer, le plus simple sera de supprimer le module
Par prudence vérifiez si cela fonctionne comme vous voulez avant de les supprimer.
Une fois terminé on peut regarder si des modifications ou simplifications peuvent être apportées
Bonsoir,
Tardivement je tente le coup. Je ne supprimerai pas dans un souci de retour à d'autres besoins. Je vous reviens avec le dénouement.
J'ai été sollicité sur des projets donc je reviens pour fermer la requête. Je n'ai pas supprimer les modules au cas où il faudrait faire un retour en arrière. Le tout fonctionne vraiment très bien.
Un grand merci pour votre aide. Belle journée.
Bonjour Dan,
J'ouvre à nouveau le billet car je me retrouve avec une problématique que je n'arrive plus ou moins à résoudre.. Lorsque je génère les données j'obtient une erreur dans mon code et malgré la désactivation de celui-ci cela me pose problème. Qu'aie-je omis de faire selon votre expertise ?
Le code :
Sub MAJ_SM()
'
' Macro1 Macro
'
'Dim WK_Resultat As Workbook
Dim Links As Variant
Dim dossier As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
dossier = "R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\"
Call Renommer
Set WK_Resultat = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse SMDPSG.xlsx")
Call Demandes_SMDPSG
Call Trente_Jours_SM
Call Copier_Coller_SMDPSG
'renommer le fichier
NouvNom = InputBox("Inscrire le nouveau nom du fichier" & vbNewLine & "Santé mentale, dépendance et services généraux")
'mettre à jour les liaisons
Call ouvrir_Fichier
'WK_Resultat.SaveAs dossier & NouvNom, XlFileFormat.xlOpenXMLWorkbook
'retirer totes les liasons
Links = WK_Resultat.LinkSources(Type:=xlLinkTypeExcelLinks)
For i = 1 To UBound(Links)
WK_Resultat.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
WK_Resultat.Save
Call FERMER_Fichier
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
MsgBox ("Ne pas oublier d'actualiser les requête!!")
End SubMerci !!Bonjour
Dans le code, essayez comme ceci
1. Supprimez cette partie de code
Links = WK_Resultat.LinkSources(Type:=xlLinkTypeExcelLinks)
For i = 1 To UBound(Links)
WK_Resultat.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i2. Ajoutez ceci à la place des lignes supprimées ci-dessus
Call supprimer_liens()
3. A la suite du code Sub MAJ_SM(), ajoutez ce code
Sub supprimer_liens()
Dim liens
Dim i As Integer
liens = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
If Not IsEmpty(liens) Then
For i = 1 To UBound(liens)
ActiveWorkbook.BreakLink Name:=liens(i), Type:=xlExcelLinks
Next i
End If
End SubCela devrait fonctionner
Bonjour Dan, à la suite de la saisie du code dans la Sub_Maj_SM j'obtiens d'autres erreurs dans le code Sub Demandes_SMDPSG.
Voici l'erreur : Set WK = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse SMDPSG.xlsx") ...pourtant tout est déclaré ...
Sub Demandes_SMDPSG()
Dim Y As Long
Dim feuille As Worksheet
Dim WK As Workbook
Dim wk2 As Workbook
Dim Code_Programme As String
Dim Plage_Recherche As Range
Dim Pourcentage_Add As Range
Dim Ligne_Guichet As Variant
Dim Col_Accepte As Variant
Dim NB_Accepte As Long
Dim Ligne_Debut As Long
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Application.AskToUpdateLinks = False
'Set WK = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\INV Fiche synthèse SMDPSG.xlsx")
'Set WK = Workbooks("INV Fiche synthèse Jeunesse.xlsx")
For Y = 4 To 10
'Ouvrir le fichier source
Base = WK_Resultat.Worksheets("Demandes").Cells(11, Y).Value
Set wk2 = Workbooks.Open("R:\DPACQ\Equipes\Équipe Éval\BD\Fiche synthèse\Demandes\" & Base & "_NB demandes selon décision.xlsx")
wk2.Worksheets(1).Range("A:G").UnMerge '.UsedRange.SpecialCells(xlCellTypeLastCell)
'Ajuster ici si ajout sous-programme
For X = 12 To 20 Step 3
'initialiser la variable à 0 pour éviter erreur lorsque le sous-programme n'est pas trouvé
NB_Accepte = 0
'Boucle sur les codes sous-programme
Set Plage_Recherche = wk2.Worksheets(1).Columns(1)
Code_Programme = WK_Resultat.Worksheets("Demandes").Cells(X, 1).Value
Set Ligne_Guichet = Plage_Recherche.Cells.Find(what:=Code_Programme, LookIn:=xlValues, LookAt:=xlWhole, searchdirection:=xlNext, SearchOrder:=xlByColumns)
'Si un résultat est trouvé
If Not Ligne_Guichet Is Nothing Then
Col_Accepte = Ligne_Guichet.Offset(0, 3).Value
'Valider si mmoins de trente jours
If Col_Accepte = "100" Then
NB_Accepte = Ligne_Guichet.Offset(0, 5).Value
'Rechercher la ligne en attente de décision
Do
Z = Z + 1
Ligne_En_Attente = Ligne_Guichet.Offset(Z, 4).Value
Loop Until Ligne_En_Attente = "" Or Ligne_Guichet.Offset(Z, 0).Value <> ""
If Ligne_En_Attente = "" Then
Nb_En_Attente = Ligne_Guichet.Offset(Z, 5).Value
Else
Nb_En_Attente = 0
End If
'Réinitialiser z
Z = 0
Else
Application.ScreenUpdating = True
wk2.Activate
Ligne_Guichet.Select
NB_Accepte = InputBox("Inscrire le nombre accepté pour" & Ligne_Guichet)
Application.ScreenUpdating = False
End If
End If
WK_Resultat.Worksheets("Demandes").Cells(X, Y) = NB_Accepte
WK_Resultat.Worksheets("Demandes").Cells(X + 1, Y) = Nb_En_Attente
Next X
wk2.Close False
Next Y
WK_Resultat.Save
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'Application.AskToUpdateLinks = True
End Sub