Transformation d'une macro en fonction pour formule
Bonjour,
Je me permet de poster un message car j'ai un problème lorsque je veux transformer ma procédure VBA en fonction VBA pour ensuite l'utiliser dans une formule. Cette procédure me permettrait d'ajouter une ligne tout en copiant celle sélectionné.
Bon jusqu'à la, je ne pense pas que ce soit très difficile mais la formule que souhaite créer aussi me pose problème. Dans l'idée j'aimerai que ma cellule en type d'équipement, lorsqu'elle est remplie (voir image jointe), me remplisse automatiquement la case Type d'intervention et ajoute des lignes si il y a plusieurs Type d'intervention (Visite de contrôle, Dépannage curatif, Intervention lourde, Entretien préventif).
Voici le code de la procédure que je n'arrive pas à transformer :
Sub ajoutintervention()
Application.ScreenUpdating = False
ActiveCell.Offset(1, 0).EntireRow.Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
Application.ScreenUpdating = True
ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(-1, 1).Value
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End Sub
La formule que j'ai essayé d'élaborer afin de résoudre mon problème :
formule : =SI([@[Type d''équipement]]<>"";SI([@[Visite de contrôle]]<>"";ET([@[Type d''intervention]]=[@[Visite de contrôle]];SI([@[Entretien préventif]]<>"";ET(ajoutintervention2();[@[Type d''intervention]]="Entretien préventif");SI([@[Dépannage curatif]]<>"";ET(ajoutintervention2();[@[Type d''intervention]]="Dépannage curatif");SI([@[Intervention lourde]]<>"";ET(ajoutintervention2();[@[Type d''intervention]]="Intervention lourde") ))))))
Et je joint aussi une capture d'écran, le fichier étant trop volumineux...
Merci de votre aide qui me sera sans doute précieuse je pense,
Bien à vous tous.
Bonjour,
Si je comprends bien ... ton objectif est de transformer ta macro en une fonction personnalisée ...
Malheureusement, une fonction personnalisée se comporte comme une formule ... donc elle ne pourra pas insérer de ligne ...
Merci pour ta réponse ! Je vais donc me pencher sur une autre solution (activation des cellules grises !!!)
Bonne journée
J'ai une autre idée sinon, je pourrai modifier une procédure d'un bouton actualiser de mon projet. Il reprend les équipements dans une autre onglet et les remplis dans la colonne "Type d'équipement". Dans l'idée ça donnerai ça :
Sub ActualiserII1()
Application.ScreenUpdating = False
Range("Tablecmossature[Type d''équipement]").EntireRow.Select
Selection.Delete Shift:=xlUp
Sheets("II.1").Select
Range("Tableequipementossature[Type d''équipement]").Select
Selection.Copy
Sheets("II.2").Select
Range("Tablecmossature[Type d''équipement]").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Range("A1").Select
Application.ScreenUpdating = True
'recopie les cellules du précédent onglets dans type d'équipement
'ébauche de ce que je voudrais arriver à faire
if CelluleTyped'équipement<>""
then
if CelluleVisitedecontrôle<>""
then
CelluleTyped'intervention="Visitedecontrôle"
if CelluleEntretienPréventif<>""
then
ajoutintervention() 'voir code plus haut
CelluleTyped'intervention="EntretienPréventif"
if CelluleDépannagecuratif<>""
then
ajoutintervention() 'voir code plus haut
CelluleTyped'intervention="Dépannagecuratif"
'même chose pour Intervention lourde
End if
End if
End if
End if
End Sub
Qu'en pensez vous ?
End Sub
De rien ...
Sur la base de la photo que tu as jointe, il me semble que tu devrais t'orienter vers le genre de solution suivante :
1. Un onglet dédié à toutes tes variables avec les types d'intervention
2. Dans ta feuille principale, une fonction de recherche qui aille puiser les infos dans cet onglet dédié ...
Bonne Continuation
Re James,
Alors du coup l'onglet est déjà crée ! Une base de données dans laquelle les équipements sont répertoriés et informe sur le fait qu'il y a oui ou non une visite de contrôle, un dépannage curatif.. etc. Les cellules du tableau où il y a le screen se remplissent toutes seules.
Merci tout de même pour ce conseil !
Re,
Sans voir ton fichier ... je ne pouvais pas deviner ...
Pour répondre plus précisément à la complexité de la formule aux multiples Si() ... il est souvent recommendé de s'appuyer sur un tableau qui concrètement recense tous les cas .... du coup recherchev() fait le travail de tous les Si() imbriqués ...
Okay je vais tenter ça, merci !
UghChaz a écrit :Okay je vais tenter ça, merci !
Bonjour,
Si tu as des difficultés ... il ne faudra pas hésiter à poster un message ...
Bonjour James007,
Je sais si tes talents d'agent secret du code VBA vont pouvoir m'aider mais je tente quand même ! Au final, j'ai créer un code pour réaliser ce que je voulais, en voici la trame :
Sub ActualiserIII1()
Application.ScreenUpdating = False
Range("Tablecmcloisonnements[Type d''équipement]").EntireRow.Select
Selection.Delete Shift:=xlUp
Sheets("III.1").Select
Range("Tableequipementcloisonnements[Type d''équipement]").Select
Selection.Copy
Sheets("III.2").Select
Range("Tablecmcloisonnements[Type d''équipement]").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Range("A1").Select
Dim cell As Range
For Each cell In Sheets("III.2").Range("Tablecmcloisonnements[Visite de contrôle]")
If InStr(CStr(cell.Value), "") > 0 Then
i = cell.Row
Sheets("II.2").Cells(i, 3) = cell.Value
End If
Next
Dim tableau() As Integer ' contient les lignes ou il faut inserer dessous une ligne
Dim k As Integer
k = 0
For Each cell In Sheets("III.2").Range("Tablecmcloisonnements[Entretien préventif]")
If InStr(CStr(cell.Value), "") > 0 Then
k = k + 1
ReDim Preserve tableau(k)
tableau(k) = cell.Row
End If
Next
'Application.ScreenUpdating = True
If UBound(tableau) > 0 Then For a = 1 To UBound(tableau)
Cells(tableau(a), 1).Offset(1, 0).EntireRow.Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
temp = temp & tableau(a) & " - "
Cells(tableau(a) + 1, 1).Value = Cells(tableau(a), 1).Value
Cells(tableau(a) + 1, 3).Value = Cells(tableau(a), 14).Value
For b = 1 To UBound(tableau)
tableau(b) = tableau(b) + 1
Next b
Next a
'MsgBox (temp)
End If
'Application.ScreenUpdating = True
' colonne curatif
Dim tableau2() As Integer ' contient les lignes ou il faut inserer dessous une ligne
Dim k2 As Integer
k2 = 0
For Each cell In Sheets("III.2").Range("Tablecmcloisonnements[Dépannage curatif]")
If InStr(CStr(cell.Value), "") > 0 Then
k2 = k2 + 1
ReDim Preserve tableau2(k2)
l = cell.Row
temp = CStr(Cells(l, 1))
n = 0
While InStr(temp, CStr(Cells(l + n, 1))) > 0
n = n + 1
'MsgBox (temp)
Wend
tableau2(k2) = l + n
End If
Next
'enlever es doublons de mon tableau2
Dim tabis() As Integer
Dim d As Integer
d = 1
tempa = 0
If UBound(tableau2) > 0 Then
tempa = tableau2(1)
ReDim Preserve tabis(1)
tabis(1) = tableau2(1)
End If
For a = 1 To UBound(tableau2)
If tempa <> tableau2(a) Then
d = d + 1
ReDim Preserve tabis(d)
tabis(d) = tableau2(a)
tempa = tabis(d)
End If
Next
For a = 1 To UBound(tabis)
Cells(tabis(a), 1).EntireRow.Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
Cells(tabis(a), 1).Value = Cells(tabis(a) - 1, 1).Value
Cells(tabis(a), 3).Value = Cells(tabis(a) - 1, 15).Value
For b = 1 To UBound(tabis)
tabis(b) = tabis(b) + 1
Next b
Next a
'colonne intervention lourde
Dim tableau3() As Integer ' contient les lignes ou il faut inserer dessous une ligne
Dim k3 As Integer
k3 = 0
For Each cell In Sheets("III.2").Range("Tablecmcloisonnements[Intervention lourde]")
If InStr(CStr(cell.Value), "") > 0 Then
k3 = k3 + 1
ReDim Preserve tableau3(k3)
l = cell.Row
temp = CStr(Cells(l, 1))
n = 0
While InStr(temp, CStr(Cells(l + n, 1))) > 0
n = n + 1
'MsgBox (temp)
Wend
tableau3(k3) = l + n
End If
Next
'enlever es doublons de mon tableau3
Dim tater() As Integer
Dim dd As Integer
dd = 1
tempa = 0
If UBound(tableau3) > 0 Then
tempa = tableau3(1)
ReDim Preserve tater(1)
tater(1) = tableau3(1)
End If
For a = 1 To UBound(tableau3)
If tempa <> tableau3(a) Then
dd = dd + 1
ReDim Preserve tater(dd)
tater(dd) = tableau3(a)
tempa = tater(dd)
End If
Next
For a = 1 To UBound(tater)
Cells(tater(a), 1).EntireRow.Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
Cells(tater(a), 1).Value = Cells(tater(a) - 1, 1).Value
Cells(tater(a), 3).Value = Cells(tater(a) - 1, 16).Value
For b = 1 To UBound(tater)
tater(b) = tater(b) + 1
Next b
Next a
Application.ScreenUpdating = True
End Sub
Petit hic, pour certaines pages aucun problème de code, et pour d'autres je reçois l'erreur pour la ligne surligné :
Erreur d'éxécution 9 : L'indice n'appartient pas à la sélection...
Bref, je ne comprend d'où cela pourrait venir !
Bonjour,
Avant toute chose, je te félicite pour ta persévérance ... !!! ... à mes yeux, c'est une qualité ... devenue trop rare
Concernant ton code ... sincèrement, à distance sans le fichier, je ne peux t'indiquer que des pistes de recherche ... surtout que si je comprends bien ... ce code fonctionne parfaitement sur certaines feuilles ...
Du coup, il faudrait t'assurer que
1. la structure de tes différentes feuilles soit rigoureusement identiques ... et que
2. par exemple, tu n'es aucune feuille totalement vide ...