Export de données d'une feuille vers onglet en fonction d'une catégorie
t
Bonjour à tous,
J'ai une petite difficulté pour sortir des données d'un onglet vers d'autres onglets en fonction de leur catégorie.
J'aimerai automatiser la chose grâce à un code VBA, j'ai essayé de suivre les informations de GMB et l'exemple qu'il a donné sur ce post https://forum.excel-pratique.com/excel/export-de-lignes-d-une-feuille-vers-une-autre-selon-criteres-... en vain..
2 jours que je me triture l'esprit dessus mais cela termine toujours par une erreur 9.
Je vous joins mon fichier, l'objectif serait de sortir les données des contrats en fonction du type de projet (voir onglet liste). Ainsi, j'aimerai avoir un onglet pour chaque type de contrat avec les informations qui y sont.
Je vous remercie d'avance pour votre précieuse aide.
Thore
3
Bonjour,
Il faut redoubler d'attention quand on adapte le code d'un autre projet, c'est presque normal que vous rencontriez une erreur.
L'erreur 9 signifie que l'indice n'appartient pas à la sélection. Il faut regarder si les feuilles utilisées existent bien (nom bien libellé, index existant), ou si les tableaux sont bien dimensionnés...
Si vous n'obtenez toujours pas de réponse, vous pouvez éventuellement poster votre code et indiquer la ligne où se produit l'erreur.
Cdlt,
t
Merci pour votre réponse.
J'avoue avoir du mal à bien comprendre les différentes fonctions du code.
Ainsi, j'ai essayé de "bidouiller" le code de GMB pour trouver la solution. J'ai repris son fichier et essayé d'afficher la colonne que j'ai ajouté (voir fichier).
Si je comprenais comment modifier le code afin d'afficher cette colonne alors je pourrais m'occuper du code de mon fichier.
Si je comprends bien dans le code suivant, tablo prend les informations de A2 jusqu'à K pour toutes les lignes non vides ?
Ensuite on regarde dans la colonne 8 si la cellule à la valeur "déjà présent".
C'es la fonction Redim que j'ai du mal à comprendre.
Je suppose que pour les j =1 to 7 et 9 to 10 servent à ne pas reprendre la colonne H qui n'apparaît pas une fois la séparation faite ?
J'espère que vous pourrez m'aider à mieux comprendre et adapter ce code à mon objectif !
Encore merci pour votre réponse.
Option Explicit
Dim tablo, tabloAS(), TabloDP(), i&, j&, kDP&, kAS&
Sub Séparer()
tablo = Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row)
kDP = 1
kAS = 1
For i = 1 To UBound(tablo, 1)
If tablo(i, 8) = "Déjà présent" Then
ReDim Preserve TabloDP(1 To 9, 1 To kDP + 1)
For j = 1 To 7
TabloDP(j, kDP) = tablo(i, j)
Next j
For j = 9 To 10
TabloDP(j - 1, kDP) = tablo(i, j)
Next j
kDP = kDP + 1
ElseIf tablo(i, 8) = "A sortir" Then
ReDim Preserve tabloAS(1 To 9, 1 To kAS + 1)
For j = 1 To 7
tabloAS(j, kAS) = tablo(i, j)
Next j
For j = 9 To 10
tabloAS(j - 1, kAS) = tablo(i, j)
Next j
kAS = kAS + 1
End If
Next i
Sheets("test").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("test").Range("A2").Resize(UBound(tabloAS, 2), 9) = Application.Transpose(tabloAS)
Sheets("Déja présents").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Déja présents").Range("A2").Resize(UBound(TabloDP, 2), 9) = Application.Transpose(TabloDP)
MsgBox "Travail terminé."
End Sub3
Ah oui, mais c'est un code qui répond à une problèmatique précise, scinder en 2 tableaux les données en fonction de la valeur de la colonne 8. Je ne sais pas si c'est ce que vous cherchez...
Le code :
- tablo prend les valeurs en A2:Kfin
- pour chaque ligne de tablo, si la colonne 8 vaut "déjà présent", on copie les valeurs de la ligne (sauf la colonne 8) dans le tabloDP (déjà présent)
- idem pour a sortir
La fonction redim permet de redimensionner le tableau au fur et à mesure de l'exécution (ici, kDP et kAS s'incrémentent quand leur condition est remplie). Et, vous aurez remarqué qu'il y a eu transposition : le tableau tablo a 10 colonnes et x lignes alors que les 2 autres tableaux ont 9 lignes (10 - 1) et y ou z colonnes (x = y + z). C'est normal car la redimension ne peut s'opérer que sur la dernière dimension du tableau, à savoir les colonnes.
Ensuite, en bas de bas, les tableaux DP et AS sont à nouveau retransposés pour coller les valeurs correctement.
J'adapte ce code pour qu'il soit légèrement plus compréhensible :
Option Explicit
Option Base 1
Dim rCopie as range
Dim tablo, tabloAS(), TabloDP()
Dim fin&, TotalDP&, TotalAS&, nDP&, nAS&, i&, j&
Sub Séparer()
fin = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne de la plage
set rCopie = Range("A2:K" & fin) 'range à copier
tablo = rCopie 'copie des valeurs dans tablo
TotalDP = application.countif(rCopie.columns(8), "Déjà présent") 'total lignes Déjà présent
TotalAS = application.countif(rCopie.columns(8), "A sortir") 'total lignes A sortir
set rCopie = Nothing 'libération variable
redim TabloDP(TotalDP, 9), TabloAS(TotalAS, 9) 'redimension définitive des 2 tableaux
For i = 1 To UBound(tablo, 1) 'pour chaque ligne du tablo
If tablo(i, 8) = "Déjà présent" Then 'si col8 vaut "deja present"
nDP = nDP + 1 'incrémentation nouvelle ligne en cours pour tabloDP
For j = 1 To 9 'pour chaque colonne de la ligne nDP de tabloDP (on copie les colonnes - sauf la 8 - de la ligne i de tablo)
if j < 8 then TabloDP(nDP, j) = tablo(i, j) ' si colonne < 8, on copie les valeurs la meme colonne de tablo
if j >= 8 then TabloDP(nDP, j) = tablo(i, j + 1) 'si colonne = 8 ou 9, on copie les valeurs de la colonne suivante de tablo
Next j
ElseIf tablo(i, 8) = "A sortir" Then ' si vaut "A sortir"
nAS = nAS + 1 'idem
For j = 1 To 9 'idem tabloAS
if j < 8 then TabloAS(nAS, j) = tablo(i, j) 'idem
if j >= 8 then TabloAS(nAS, j) = tablo(i, j + 1) 'idem
Next j
End If
Next i
Sheets("test").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("test").Range("A2").Resize(TotalAS, 9) = tabloAS
Sheets("Déja présents").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Déja présents").Range("A2").Resize(TotalDP, 9) = TabloDP
MsgBox "Travail terminé."
End SubJ'espère que vous arriverez mieux à adapter...
Cdlt,
t
Encore une fois un grand merci pour votre réponse.
Mon tableau de base possède plus de 30 colonnes. J'essaie donc de modifier le code de ce fichier pour afficher également la colonne K et sans supprimer la colonne 8.
J'ai voulu mettre ce code mais ça ne fonctionne pas, erreur 9 encore une fois..
L'erreur apparait à cette ligne "TabloDP(nDP, j) = tablo(i, j) ' si colonne < 8, on copie les valeurs la meme colonne de tablo"
j'ai sauté des lignes pour qu'elle soit facilement repérée dans le code.
Et déjà hier c'était ce même problème que j'obtenais.. je ne comprends pas bien la fonction probablement..
Option Explicit
Option Base 1
Dim rCopie As Range
Dim tablo, tabloAS(), TabloDP()
Dim fin&, TotalDP&, TotalAS&, nDP&, nAS&, i&, j&
Sub Séparer()
fin = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne de la plage
Set rCopie = Range("A2:K" & fin) 'range à copier
tablo = rCopie 'copie des valeurs dans tablo
TotalDP = Application.CountIf(rCopie.Columns(8), "Déjà présent") 'total lignes Déjà présent
TotalAS = Application.CountIf(rCopie.Columns(8), "A sortir") 'total lignes A sortir
Set rCopie = Nothing 'libération variable
ReDim TabloDP(TotalDP, 9), tabloAS(TotalAS, 9) 'redimension définitive des 2 tableaux
For i = 1 To UBound(tablo, 1) 'pour chaque ligne du tablo
If tablo(i, 8) = "Déjà présent" Then 'si col8 vaut "deja present"
nDP = nDP + 1 'incrémentation nouvelle ligne en cours pour tabloDP
For j = 1 To 10
TabloDP(nDP, j) = tablo(i, j) ' si colonne < 8, on copie les valeurs la meme colonne de tablo
Next j
ElseIf tablo(i, 8) = "A sortir" Then ' si vaut "A sortir"
nAS = nAS + 1 'idem
For j = 1 To 10 'idem tabloAS
tabloAS(nAS, j) = tablo(i, j) 'idem
Next j
End If
Next i
Sheets("test").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("test").Range("A2").Resize(TotalAS, 9) = tabloAS
Sheets("Déja présents").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Déja présents").Range("A2").Resize(TotalDP, 9) = TabloDP
MsgBox "Travail terminé."
End Sub3
J'ai l'impression que c'est parce que vous avez modifié vos boucles sur les colonnes (j = 1 to 10) sans pour autant modifier les dimensions des 2 tableaux.
Dites-moi comment ça marche avec celui-ci :
Option Explicit
Option Base 1
Dim rCopie As Range
Dim tablo, tabloAS(), TabloDP()
Dim fin&, TotalDP&, TotalAS&, nDP&, nAS&, i&, j&
Sub Séparer()
fin = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne de la plage
Set rCopie = Activesheet.Range("A2:K" & fin) 'range à copier
tablo = rCopie 'copie des valeurs dans tablo
TotalDP = Application.CountIf(rCopie.Columns(8), "Déjà présent") 'total lignes Déjà présent
TotalAS = Application.CountIf(rCopie.Columns(8), "A sortir") 'total lignes A sortir
Set rCopie = Nothing 'libération variable
ReDim TabloDP(TotalDP, 11), tabloAS(TotalAS, 11) 'redimension définitive des 2 tableaux
For i = 1 To UBound(tablo, 1) 'pour chaque ligne du tablo
If tablo(i, 8) = "Déjà présent" Then 'si col8 vaut "deja present"
nDP = nDP + 1 'incrémentation nouvelle ligne en cours pour tabloDP
For j = 1 To 11
TabloDP(nDP, j) = tablo(i, j)
Next j
ElseIf tablo(i, 8) = "A sortir" Then ' si vaut "A sortir"
nAS = nAS + 1 'idem
For j = 1 To 11 'idem tabloAS
tabloAS(nAS, j) = tablo(i, j) 'idem
Next j
End If
Next i
Sheets("test").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("test").Range("A2").Resize(TotalAS, 11) = tabloAS
Sheets("Déja présents").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Déja présents").Range("A2").Resize(TotalDP, 11) = TabloDP
MsgBox "Travail terminé."
End SubDonc il garde toutes les valeurs pour les 10 premières colonnes en continuant les tests sur la colonne 8...
Edit, d'ailleurs il faut les passer à 11 colonnes car K est la 11è colonne. Le code est donc modifié en conséquence.
t
Le code fourni a fonctionné et m'a permis de l'adapter à mes besoins.
Je vous remercie donc énormément pour votre aide. Votre aide m'a été très précieuse et je suis ravi de pouvoir clôturer ce sujet.
Je vous souhaite une belle fin de journée ainsi qu'un bon week end.
t
Juste une petite dernière question. Lorsque je lance ma macro, elle fonctionne. Mais lorsque je souhaite la relancer l'erreur 9 s'affiche à nouveau. Je suis alors obligé de fermer le fichier et le rouvrir pour que cela fonctionne.
Savez vous d'ou vient le problème?
Merci d'avance.
Voici le code
Option Explicit
Option Base 1
Dim rCopie As Range
Dim Tablo, TabloLUE(), TabloEU(), TabloR(), TabloANR(), TabloUL(), TabloPR(), TabloAU()
Dim fin&, TotalEU&, TotalLUE&, TotalR&, TotalANR&, TotalUL&, TotalPR&, TotalAU&, nAU&, nPR&, nUL&, nR&, nEU&, nLUE&, nANR&, i&, j&
Sub Séparer()
fin = Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne de la plage
Set rCopie = ActiveSheet.Range("A2:AI" & fin) 'range à copier
Tablo = rCopie 'copie des valeurs dans tablo
TotalEU = Application.CountIf(rCopie.Columns(2), "Europe") 'total lignes Déjà présent
TotalLUE = Application.CountIf(rCopie.Columns(2), "LUE") 'total lignes A sortir
TotalANR = Application.CountIf(rCopie.Columns(2), "ANR")
TotalR = Application.CountIf(rCopie.Columns(2), "Région")
TotalUL = Application.CountIf(rCopie.Columns(2), "Université de Lorraine")
TotalPR = Application.CountIf(rCopie.Columns(2), "Prestation")
TotalAU = Application.CountIf(rCopie.Columns(2), "Autre")
Set rCopie = Nothing 'libération variable
ReDim TabloEU(TotalEU, 35), TabloLUE(TotalLUE, 35), TabloANR(TotalANR, 35), TabloR(TotalR, 35), TabloUL(TotalUL, 35), TabloPR(TotalPR, 35), TabloAU(TotalAU, 35) 'redimension définitive des 2 tableaux
For i = 1 To UBound(Tablo, 1) 'pour chaque ligne du tablo
If Tablo(i, 2) = "Europe" Then 'si col8 vaut "deja present"
nEU = nEU + 1 'incrémentation nouvelle ligne en cours pour tabloDP
For j = 1 To 35
TabloEU(nEU, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "LUE" Then
nLUE = nLUE + 1
For j = 1 To 35
TabloLUE(nLUE, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Région" Then
nR = nR + 1
For j = 1 To 35
TabloR(nR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "ANR" Then
nANR = nANR + 1
For j = 1 To 35
TabloANR(nANR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Université de Lorraine" Then
nUL = nUL + 1
For j = 1 To 35
TabloUL(nUL, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Prestation" Then
nPR = nPR + 1
For j = 1 To 35
TabloPR(nPR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Autre" Then
nAU = nAU + 1
For j = 1 To 35
TabloAU(nAU, j) = Tablo(i, j)
Next j
End If
Next i
Sheets("LUE").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("LUE").Range("A2").Resize(TotalLUE, 35) = TabloLUE
Sheets("Europe").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Europe").Range("A2").Resize(TotalEU, 35) = TabloEU
Sheets("Région").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Région").Range("A2").Resize(TotalR, 35) = TabloR
Sheets("ANR").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("ANR").Range("A2").Resize(TotalANR, 35) = TabloANR
Sheets("Université de Lorraine").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Université de Lorraine").Range("A2").Resize(TotalUL, 35) = TabloUL
Sheets("Prestation").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Prestation").Range("A2").Resize(TotalPR, 35) = TabloPR
Sheets("Autre").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Autre").Range("A2").Resize(TotalAU, 35) = TabloAU
MsgBox "Travail terminé."
End Sub3
Bonjour,
Pouvez-vous me dire sur quelle ligne se trouve l'erreur ?
t
Bonjour,
L'erreur est ici :
TabloEU(nEU, j) = Tablo(i, j)3
Bonjour,
Franchement, en l'état, je n'ai pas d'idée. Vous avez adapté le code précédent qui marchait...
Pour moi, l'erreur porterait sur le tableau Tablo... Il faudrait que je teste avec votre fichier pour voir.
Cdlt,
t
Oui le code fonctionne mais qu'une fois par "session".
Voila le fichier. Encore merci pour votre aide.
Cordialement
3
Salut thore57,
C'était le activesheet qui posait problème. Dès que tu allais regarder tes résultats sur les autres feuilles et que tu tentais de réexécuter le code, ça créait un conflit car tu te trouvais sur une "mauvaise" activesheet.
Tu ne devrais plus avoir de soucis maintenant, enfin je l'espère
Bonne soirée !
t
Un dernier grand merci pour conclure ce post.
Tout fonctionne parfaitement désormais.
Bonne continuation
t
Option Explicit
Option Base 1
Sub Séparer()
Dim rCopie As Range
Dim Tablo, TabloLUE(), TabloEU(), TabloR(), TabloANR(), TabloUL(), TabloPR(), TabloAU(), TabloT()
Dim fin&, TotalEU&, TotalLUE&, TotalR&, TotalANR&, TotalUL&, TotalPR&, TotalAU&, TotalT, nT&, nAU&, nPR&, nUL&, nR&, nEU&, nLUE&, nANR&, i&, j&
With Sheets("Base") '<<<<< FEUILLE DE rcopie et de fin !!!
fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne de la plage
Set rCopie = .Range("A2:AI" & fin) 'range à copier
End With
Tablo = rCopie 'copie des valeurs dans tablo
TotalEU = Application.CountIf(rCopie.Columns(2), "Europe") 'total lignes Déjà présent
TotalLUE = Application.CountIf(rCopie.Columns(2), "LUE") 'total lignes A sortir
TotalANR = Application.CountIf(rCopie.Columns(2), "ANR")
TotalR = Application.CountIf(rCopie.Columns(2), "Région")
TotalUL = Application.CountIf(rCopie.Columns(2), "Université de Lorraine")
TotalPR = Application.CountIf(rCopie.Columns(2), "Prestation")
TotalAU = Application.CountIf(rCopie.Columns(2), "Autre")
TotalT = Application.CountIf(rCopie.Columns(2), "Thèse")
Set rCopie = Nothing 'libération variable
ReDim TabloT(TotalT, 35), TabloEU(TotalEU, 35), TabloLUE(TotalLUE, 35), TabloANR(TotalANR, 35), TabloR(TotalR, 35), TabloUL(TotalUL, 35), TabloPR(TotalPR, 35), TabloAU(TotalAU, 35) 'redimension définitive des 2 tableaux
For i = 1 To UBound(Tablo, 1) 'pour chaque ligne du tablo
If Tablo(i, 2) = "Europe" Then 'si col8 vaut "deja present"
nEU = nEU + 1 'incrémentation nouvelle ligne en cours pour tabloDP
For j = 1 To 35
TabloEU(nEU, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "LUE" Then
nLUE = nLUE + 1
For j = 1 To 35
TabloLUE(nLUE, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Région" Then
nR = nR + 1
For j = 1 To 35
TabloR(nR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "ANR" Then
nANR = nANR + 1
For j = 1 To 35
TabloANR(nANR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Université de Lorraine" Then
nUL = nUL + 1
For j = 1 To 35
TabloUL(nUL, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Prestation" Then
nPR = nPR + 1
For j = 1 To 35
TabloPR(nPR, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Autre" Then
nAU = nAU + 1
For j = 1 To 35
TabloAU(nAU, j) = Tablo(i, j)
Next j
ElseIf Tablo(i, 2) = "Thèse" Then
nT = nT + 1
For j = 1 To 35
TabloT(nT, j) = Tablo(i, j)
Next j
End If
Next i
Sheets("LUE").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("LUE").Range("A2").Resize(TotalLUE, 35) = TabloLUE
Sheets("Europe").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Europe").Range("A2").Resize(TotalEU, 35) = TabloEU
Sheets("Région").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Région").Range("A2").Resize(TotalR, 35) = TabloR
Sheets("ANR").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("ANR").Range("A2").Resize(TotalANR, 35) = TabloANR
Sheets("Université de Lorraine").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Université de Lorraine").Range("A2").Resize(TotalUL, 35) = TabloUL
Sheets("Prestation").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Prestation").Range("A2").Resize(TotalPR, 35) = TabloPR
Sheets("Autre").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Autre").Range("A2").Resize(TotalAU, 35) = TabloAU
Sheets("Thèse").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Sheets("Thèse").Range("A2").Resize(TotalT, 35) = TabloT
MsgBox "Travail terminé."
End Sub
Option Explicit
Dim Ws As Worksheet 'Ici on défini les variables qu'on réutilisera dans le code
Dim op1 As String
Dim op2 As String
Dim op3 As String
Dim op4 As String
Dim op5 As String
Private Sub UserForm_Initialize() 'Ce Sub se lance à l'ouverture du formulaire
Dim j As Integer 'Variable
Dim i As Integer 'Variable
With Me.ComboBoxNum 'Défini la liste déroulante numéro de contrat
For j = 2 To Range("A" & Rows.Count).End(xlUp).Row 'Compte pour la colonne A le nombre de ligne ou il y a une information à partir de la ligne 2 (J=2)
.AddItem Range("A" & j) 'Ajoute les valeurs de chaque ligne pour la colonne A au menu déroulant
Next j
End With
With Me.ComboBoxAcro 'Défini la liste déroulante acronyme
For j = 2 To Range("C" & Rows.Count).End(xlUp).Row 'Compte pour la colonne C le nombre de ligne ou il y a une information à partir de la ligne 2 (J=2)
.AddItem Range("C" & j) 'Ajoute les Acronyme à la liste déroulante
Next j
End With
With Me.ComboBoxTypeProjet 'Liste déroulante Type de Projet
For j = 2 To Worksheets("Listes").Range("A" & Rows.Count).End(xlUp).Row 'Compte le nombre de cellules avec une information dans la colonne A de la feuille Listes
.AddItem Worksheets("Listes").Range("A" & j) 'Ajoute les valeurs des lignes avec du texte pour la colonne A de la feuille Listes
Next j
End With
With Me.ComboBoxAxe1 'Liste déroulante Axe du coporteur 1
For j = 2 To Worksheets("Listes").Range("C" & Rows.Count).End(xlUp).Row 'Compte le nombre de cellules avec une information dans la colonne C de la feuille Listes
.AddItem Worksheets("Listes").Range("C" & j) 'Ajoute les valeurs des lignes avec du texte pour la colonne C de la feuille Listes
Next j
End With
With Me.ComboBoxAxe2 'Liste déroulante Axe du coporteur 2
For j = 2 To Worksheets("Listes").Range("C" & Rows.Count).End(xlUp).Row 'Compte le nombre de cellules avec une information dans la colonne C de la feuille Listes
.AddItem Worksheets("Listes").Range("C" & j) 'Ajoute les valeurs des lignes avec du texte pour la colonne C de la feuille Listes
Next j
End With
With Me.ComboBoxCentreFinancier 'Liste déroulante Centre financier
For j = 2 To Worksheets("Listes").Range("H" & Rows.Count).End(xlUp).Row 'Compte le nombre de cellules avec une information dans la colonne H de la feuille Listes
.AddItem Worksheets("Listes").Range("H" & j) 'Ajoute les valeurs des lignes avec du texte pour la colonne H de la feuille Listes
Next j
End With
With Me.ComboBoxCentreCoût 'Liste déroulante Centre coût
For j = 2 To Worksheets("Listes").Range("J" & Rows.Count).End(xlUp).Row 'Compte le nombre de cellules avec une information dans la colonne J de la feuille Listes
.AddItem Worksheets("Listes").Range("J" & j) 'Ajoute les valeurs des lignes avec du texte pour la colonne J de la feuille Listes
Next j
End With
End Sub
Private Sub ComboBoxNum_Change() 'Pour que quand on choisisse un numéro de contrat tout apparaisse
Dim Line As Integer 'Défini les variables
Dim i As Integer
Set Ws = Sheets("Base")
If Me.ComboBoxNum.ListIndex = -1 Then Exit Sub 'Si il n'y a pas de contrat dans la base alors on sort de cette fonction ; c'est une sécurité
Line = Me.ComboBoxNum.ListIndex + 2 'Défini la variable Line comme le nombre de contrats + 2
ComboBoxTypeProjet = Cells(Line, "B") 'La valeur de la ComboBoxTypeProjet est égale à la valeur se trouvant à la ligne LINE et à la colonne B
For i = 1 To 6 'Pour les textboxI avec I allant de 1 à 6 on affiche les informations se trouvant à la ligne LINE et à la colonne I+2
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 2)
Next i
ComboBoxAxe1 = Cells(Line, "J") 'La valeur de la ComboBoxAxe1 est égale à la valeur se trouvant à la ligne LINE et à la colonne J
ComboBoxAxe2 = Cells(Line, "N") 'La valeur de la ComboBoxAxe1 est égale à la valeur se trouvant à la ligne LINE et à la colonne N
For i = 7 To 8 'Pour les textboxI avec I allant de 7 à 8 on affiche les informations se trouvant à la ligne LINE et à la colonne I+4
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 4)
Next i
For i = 9 To 10 'Pour les textboxI avec I allant de 9 à 10 on affiche les informations se trouvant à la ligne LINE et à la colonne I+6
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 6)
Next i
For i = 11 To 18 'Pour les textboxI avec I allant de 11 à 18 on affiche les informations se trouvant à la ligne LINE et à la colonne I+10
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 10)
Next i
ComboBoxCentreFinancier = Cells(Line, "AC") 'La valeur de la ComboBoxCentreFinancier se trouve à la ligne LINE et dans la colonne AC
ComboBoxCentreCoût = Cells(Line, "AD") 'La valeur de la ComboBoxCentreCoût se trouve à la ligne LINE et dans la colonne AD
For i = 19 To 22 'Pour les textboxI avec I allant de 19 à 22 on affiche les informations se trouvant à la ligne LINE et à la colonne I+12
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 12)
Next i
TextBox23 = Cells(Line, "R") 'La valeur de la Text Box 23 se trouve à la ligne LINE et la colonne R
'Pour les boutons à cocher
'Si la cellule à la ligne Line et la colonne I a pour valeur H alors on coche le bouton 1
If Cells(Line, "I") = "H" Then OptionButton1 = True 'Coche le bouton H si la colonne coporteur 1 a pour valeur H
If Cells(Line, "I") = "F" Then OptionButton2 = True 'Coche le bouton F si coporteur 1 F
If Cells(Line, "M") = "H" Then OptionButton3 = True 'Coche le bouton H si coporteur 2 H
If Cells(Line, "M") = "F" Then OptionButton4 = True 'Coche le bouton F si coporteur 2 F
If Cells(Line, "Q") = "Oui" Then OptionButton5 = True 'Coche le bouton Oui si laboratoire coordinateur
If Cells(Line, "Q") = "Non" Then OptionButton6 = True 'Coche le bouton Non si le laboratoire n'est pas coordinateur
If Cells(Line, "T") = "Oui" Then OptionButton7 = True 'Coche le bouton Oui si le projet est retenu
If Cells(Line, "T") = "Non" Then OptionButton8 = True 'Coche le bouton Non si le laboratoire n'est pas retenu
If Cells(Line, "S") = "Oui" Then OptionButton9 = True 'Coche le bouton Oui si le projet est admissible
If Cells(Line, "S") = "Non" Then OptionButton10 = True 'Coche le bouton Non si le laboratoire n'est pas admissible
End Sub
Private Sub ComboBoxAcro_Change() 'Pour que quand on choisisse un numéro de contrat tout apparaisse
'Les informations sont exactement les mêmes que dans le sub précédent à l'exception de ligne qui devient line ici
Dim Line As Integer
Dim i As Integer
Set Ws = Sheets("Base")
If Me.ComboBoxAcro.ListIndex = -1 Then Exit Sub
Line = Me.ComboBoxAcro.ListIndex + 2
ComboBoxNum = Cells(Line, "A")
ComboBoxTypeProjet = Cells(Line, "B") 'affiche dans la combo box
For i = 1 To 6 'textbox à la suite
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 2)
Next i
ComboBoxAxe1 = Cells(Line, "J")
ComboBoxAxe2 = Cells(Line, "N")
For i = 7 To 8
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 4)
Next i
For i = 9 To 10
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 6)
Next i
For i = 11 To 18
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 10)
Next i
ComboBoxCentreFinancier = Cells(Line, "AC")
ComboBoxCentreCoût = Cells(Line, "AD")
For i = 19 To 22
Me.Controls("TextBox" & i) = Ws.Cells(Line, i + 12)
Next i
TextBox23 = Cells(Line, "R")
If Cells(Line, "I") = "H" Then OptionButton1 = True 'Affiche les oui non et H/F
If Cells(Line, "I") = "F" Then OptionButton2 = True
If Cells(Line, "M") = "H" Then OptionButton3 = True
If Cells(Line, "M") = "F" Then OptionButton4 = True
If Cells(Line, "Q") = "Oui" Then OptionButton5 = True
If Cells(Line, "Q") = "Non" Then OptionButton6 = True
If Cells(Line, "T") = "Oui" Then OptionButton7 = True
If Cells(Line, "T") = "Non" Then OptionButton8 = True
If Cells(Line, "S") = "Oui" Then OptionButton9 = True
If Cells(Line, "S") = "Non" Then OptionButton10 = True
End Sub
'Action bouton ajouter
Private Sub CommandButton1_Click()
Worksheets("Base").Activate
Dim Ligne As Integer
Ligne = Range("A65000").End(xlUp).Row + 1 'Variable ligne = le nombre de ligne de la colonne A qui possèdent déja une infromation + 1 car on souhaite ajouter une ligne
Sheets("Base").Cells(Ligne, 1) = Ligne - 1 'Ajoute le numéro de contrat on fait -1 car on a une valeur de titre dans la colonne A
'Pour chaque ligne on ajoute à la cellule de la ligne LIGNE et à la colonne numéro 1,2 etc la valeur à droite du égal
'Toutes les prochaines lignes permettent de mettre les données dans une nouvelle ligne
Sheets("Base").Cells(Ligne, 2) = ComboBoxTypeProjet 'La cellule à la ligne LIGNE de la deuxième colonne prend la valeur du ComboBoxTypeProjet
Sheets("Base").Cells(Ligne, 3) = TextBox1
Sheets("Base").Cells(Ligne, 4) = TextBox2
Sheets("Base").Cells(Ligne, 5) = TextBox3
Sheets("Base").Cells(Ligne, 6) = TextBox4
Sheets("Base").Cells(Ligne, 7) = TextBox5
Sheets("Base").Cells(Ligne, 8) = TextBox6
Sheets("Base").Cells(Ligne, 9) = op1
Sheets("Base").Cells(Ligne, 10) = ComboBoxAxe1
Sheets("Base").Cells(Ligne, 11) = TextBox7
Sheets("Base").Cells(Ligne, 12) = TextBox8
Sheets("Base").Cells(Ligne, 13) = op2
Sheets("Base").Cells(Ligne, 14) = ComboBoxAxe2
Sheets("Base").Cells(Ligne, 15) = TextBox9
Sheets("Base").Cells(Ligne, 16) = TextBox10
Sheets("Base").Cells(Ligne, 17) = op3
Sheets("Base").Cells(Ligne, 18) = TextBox23
Sheets("Base").Cells(Ligne, 19) = op5
Sheets("Base").Cells(Ligne, 20) = op4
Sheets("Base").Cells(Ligne, 21) = TextBox11
Sheets("Base").Cells(Ligne, 22) = TextBox12
Sheets("Base").Cells(Ligne, 23) = TextBox13
Sheets("Base").Cells(Ligne, 24) = TextBox14
Sheets("Base").Cells(Ligne, 25) = TextBox15
Sheets("Base").Cells(Ligne, 26) = TextBox16
Sheets("Base").Cells(Ligne, 27) = TextBox17
Sheets("Base").Cells(Ligne, 28) = TextBox18
Sheets("Base").Cells(Ligne, 29) = ComboBoxCentreFinancier
Sheets("Base").Cells(Ligne, 30) = ComboBoxCentreCoût
Sheets("Base").Cells(Ligne, 31) = TextBox19
Sheets("Base").Cells(Ligne, 32) = TextBox20
Sheets("Base").Cells(Ligne, 33) = TextBox21
Sheets("Base").Cells(Ligne, 34) = TextBox22
Unload Me 'Ferme l'userform
UserForm1.Show 'Rouvre l'userform
End Sub
Private Sub CommandButton2_Click() 'Bouton modifier
Dim Line As Integer 'Définition des variables
Worksheets("Base").Activate
Line = Me.ComboBoxNum.ListIndex + 2
If Line < 2 Then
MsgBox ("Choisir un contrat") 'Empêche de modifier si aucun contrat n'a été choisi
Exit Sub
Else
Sheets("Base").Cells(Line, 2) = ComboBoxTypeProjet 'La celulle à la ligne Line de la deuxième colonne prend la valeur de la ComboBoxTypeProjet
Sheets("Base").Cells(Line, 3) = TextBox1
Sheets("Base").Cells(Line, 4) = TextBox2
Sheets("Base").Cells(Line, 5) = TextBox3
Sheets("Base").Cells(Line, 6) = TextBox4
Sheets("Base").Cells(Line, 7) = TextBox5
Sheets("Base").Cells(Line, 8) = TextBox6
Sheets("Base").Cells(Line, 9) = op1
Sheets("Base").Cells(Line, 10) = ComboBoxAxe1
Sheets("Base").Cells(Line, 11) = TextBox7
Sheets("Base").Cells(Line, 12) = TextBox8
Sheets("Base").Cells(Line, 13) = op2
Sheets("Base").Cells(Line, 14) = ComboBoxAxe2
Sheets("Base").Cells(Line, 15) = TextBox9
Sheets("Base").Cells(Line, 16) = TextBox10
Sheets("Base").Cells(Line, 17) = op3
Sheets("Base").Cells(Line, 18) = TextBox23
Sheets("Base").Cells(Line, 19) = op5
Sheets("Base").Cells(Line, 20) = op4
Sheets("Base").Cells(Line, 21) = TextBox11
Sheets("Base").Cells(Line, 22) = TextBox12
Sheets("Base").Cells(Line, 23) = TextBox13
Sheets("Base").Cells(Line, 24) = TextBox14
Sheets("Base").Cells(Line, 25) = TextBox15
Sheets("Base").Cells(Line, 26) = TextBox16
Sheets("Base").Cells(Line, 27) = TextBox17
Sheets("Base").Cells(Line, 28) = TextBox18
Sheets("Base").Cells(Line, 29) = ComboBoxCentreFinancier
Sheets("Base").Cells(Line, 30) = ComboBoxCentreCoût
Sheets("Base").Cells(Line, 31) = TextBox19
Sheets("Base").Cells(Line, 32) = TextBox20
Sheets("Base").Cells(Line, 33) = TextBox21
Sheets("Base").Cells(Line, 34) = TextBox22
End If
Unload Me 'Ferme l'userform
UserForm1.Show 'Ouvre l'userform
End Sub
Private Sub CommandButton3_Click() 'Commande fermer
'Les commandes suivantes permettent de convertir automatiquement toutes les valeurs des colonnes O P Y Z AA AB
'Car lorsqu'on utilise le masque de saisie c'est du format texte
Columns("O:O").Select 'Selectionne la colonne O et transforme le texte en valeur numérique
Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("P:P").Select
Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("Y:Y").Select
Selection.TextToColumns Destination:=Range("Y1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("Z:Z").Select
Selection.TextToColumns Destination:=Range("Z1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("AA:AA").Select
Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("AB:AB").Select
Selection.TextToColumns Destination:=Range("AB1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Unload Me 'Ferme l'userform
End Sub
Private Sub OptionButton1_Click() 'Bouton Homme/Femme coporteur 1
If OptionButton1.Value = True Then op1 = "H" 'Donne la valeur H à la variable op1 si le bouton H est coché
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then op1 = "F" 'Donne la valeur F à la variable op1 si le bouton F est coché
End Sub
Private Sub OptionButton3_Click()
If OptionButton3.Value = True Then op2 = "H" 'Bouton Homme/Femme coporteur 2
End Sub
Private Sub OptionButton4_Click()
If OptionButton4.Value = True Then op2 = "F"
End Sub
Private Sub OptionButton5_Click() 'Bouton Oui/Non pour laboratoire coordinateur
If OptionButton5.Value = True Then op3 = "Oui"
End Sub
Private Sub OptionButton6_Click()
If OptionButton6.Value = True Then op3 = "Non"
End Sub
Private Sub OptionButton7_Click() 'Bouton Oui/Non pour projet retenu
If OptionButton7.Value = True Then op4 = "Oui"
End Sub
Private Sub OptionButton8_Click()
If OptionButton8.Value = True Then op4 = "Non"
End Sub
Private Sub OptionButton9_Click() 'Bouton Oui/Non pour projet admissible
If OptionButton9.Value = True Then op5 = "Oui"
End Sub
Private Sub OptionButton10_Click()
If OptionButton10.Value = True Then op5 = "Non"
End Sub
Private Sub TextBox1_Change() 'Transforme le texte automatiquement en majuscule Acronyme
TextBox1.Text = UCase(TextBox1.Text) 'Les valeurs de la TextBox sont transformées en majuscule
End Sub
Private Sub TextBox5_Change() 'Transforme le texte automatiquement en majuscule Nom Coporteur 1
TextBox5.Text = UCase(TextBox5.Text)
End Sub
Private Sub TextBox7_Change() 'Transforme le texte automatiquement en majuscule Nom Coporteur 2
TextBox7.Text = UCase(TextBox7.Text)
End Sub
Private Sub TextBox19_Change() 'Transforme le texte automatiquement en majuscule Code EOTP
TextBox19.Text = UCase(TextBox19.Text)
End Sub3
Merci de ton retour thore ! Bonne continuation à toi aussi !