XL 2013 Formule en VBA

[maval]

Bonjour

J'ai une formule dans une feuille que j'aimerai passé par le VBA. Ma Formule;

=SI(NON(ESTVIDE(G229));"DCD";SI(ESTVIDE(D229);"";DATEDIF(D229;AUJOURDHUI();"y")&" Ans"))

en sachant que j'ai déjà un code dans la même feuille qui est;

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim r As Range, n&, a$(), x$, y$
 Set r = Intersect(Target, [D:G], Me.UsedRange)
 If r Is Nothing Then Exit Sub
 Application.EnableEvents = False
 For Each r In r 'si entrées multiple (copier-coller)
   n = n + 1
   ReDim Preserve a(1 To 2, 1 To n)
   x = CStr(r.Value2)
   If IsNumeric(x) Then
     y = Format(x, "#0\/00\/0000")
     If (x Like "#######" Or x Like "########") And IsDate(y) Then
       a(1, n) = r.Address
       a(2, n) = Format(y, "m/d/yyyy")
     Else
       Application.Undo 'annulation
       GoTo 1
     End If
   End If
 Next
 For n = 1 To UBound(a, 2)
   If a(1, n) <> "" Then
     With Range(a(1, n))
       .Value = a(2, n)
       If Not IsNumeric(.Value2) Then .Value = "" 'autre cas d'annulation
     End With
   End If
 Next
 1 [D:G].NumberFormat = "dd/mm/yyyy" 'format modifiable
 Application.EnableEvents = True
 End Sub

Je vous remercie de votre aide

 

[Cougar]

Re : Formule en VBA

Bonsoir Maval,

Et cette formule doit être à quel endroit dans ton code ?

Tu peux toujours : Range("xxx111").select
ActiveCell.FormulaR1C1 = _
"=IF(NOT(ISBLANK(R[228]C[6])),""DCD"",IF(ISBLANK(R[228]C[3]),"""",DATEDIF(R[228]C[3],TODAY(),""y"")&"" Ans""))"
Cougar

 

[maval]

Re : Formule en VBA

Bonjour Cougar

Cette formule s'applique pour la colonne "E"
Merci

 

[Cougar]

Re : Formule en VBA

Bonjour maval,

À placer au bon endroit :
... ton colde
Range("e65000").End(xlUp).Offset(1, 0).Select 'choisir la dernière cellule vide de la colonne E
ActiveCell.FormulaR1C1 = _
"=IF(NOT(ISBLANK(R[228]C[6])),""DCD"",IF(ISBLANK(R[228]C[3]),"""",DATEDIF(R[228]C[3],TODAY(),""y"")&"" Ans""))"
...suite de ton code

Cougar

 

[maval]

Re : Formule en VBA

Re,

Non il bug erreur La méthode FormulaR1C1 de l'objet Range a échoué.

A quoi correspond [228]C[6 [228]C[3] [228]C[3],TODAY

Si 228 correspond au N° de ligne et que 6 et 3 correspond au N° de la colonne
Pour les colonnes c'est 7 et 4 et les lignes c'est ligne de 2 à 1000

 

[maval]

Re : Formule en VBA

Re,

Personne peut me dire?

Bonne journée

 

[job75]

Re : Formule en VBA

Bonjour maval, hello Cougar,

Il s'agit d'une macro que j'ai donnée récemment, alors je la complète à la fin avec votre formule :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, r As Range, n&, a$(), x$, y$
Set P = Intersect(Target, [D:G], Me.UsedRange)
If P Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In P 'si entrées multiple (copier-coller)
  n = n + 1
  ReDim Preserve a(1 To 2, 1 To n)
  x = CStr(r.Value2)
  If IsNumeric(x) Then
    y = Format(x, "#0\/00\/0000")
    If (x Like "#######" Or x Like "########") And IsDate(y) Then
      a(1, n) = r.Address
      a(2, n) = Format(y, "m/d/yyyy")
    Else
      Application.Undo 'annulation
      GoTo 1
    End If
  End If
Next r
For n = 1 To UBound(a, 2)
  If a(1, n) <> "" Then
    With Range(a(1, n))
      .Value = a(2, n)
      If Not IsNumeric(.Value2) Then .Value = "" 'autre cas d'annulation
    End With
  End If
Next n
With Intersect(P.EntireRow, [E:E])
  .FormulaR1C1 = "=IF(NOT(ISBLANK(RC7)),""DCD"",IF(ISNUMBER(RC4),DATEDIF(RC4,TODAY(),""y"")&"" ans"",""""))"
  For Each r In .Areas
    r = r.Value 'supprime les formules
  Next r
End With
1 [D:G].NumberFormat = "dd/mm/yyyy" 'format modifiable
Application.EnableEvents = True
End Sub

Notez que les âges en colonne E sont rétablis si l'on tente de les modifier ou de les effacer.

A+

 

[maval]

Re : Formule en VBA

Bonjour Job

Et merci encore de votre aide. J'ai un petit souci que j'explique dans ma feuille j'espère m'avoir bien expliquer.

Je joint mon code qui se trouve dans le formulaire

Private Sub CmdB_Quitter_Click()
Unload Me
End Sub

Private Sub OptB_Accueil_Click()
MultiPage1.Pages(0).Visible = True: MultiPage1.Pages(1).Visible = False: MultiPage1.Pages(2).Visible = False: MultiPage1.Pages(3).Visible = False: MultiPage1.Pages(4).Visible = False
End Sub
Private Sub OptB_Etat_Civil_Click()
MultiPage1.Pages(1).Visible = True: MultiPage1.Pages(0).Visible = False: MultiPage1.Pages(2).Visible = False: MultiPage1.Pages(3).Visible = False: MultiPage1.Pages(4).Visible = False
End Sub
Private Sub OptB_Biographie_Click()
MultiPage1.Pages(2).Visible = True: MultiPage1.Pages(0).Visible = False: MultiPage1.Pages(1).Visible = False: MultiPage1.Pages(3).Visible = False: MultiPage1.Pages(4).Visible = False
End Sub
Private Sub OptB_Filmographie_Click()
MultiPage1.Pages(3).Visible = True: MultiPage1.Pages(0).Visible = False: MultiPage1.Pages(1).Visible = False: MultiPage1.Pages(2).Visible = False: MultiPage1.Pages(4).Visible = False
End Sub
Private Sub OptB_Récompenses_Click()
MultiPage1.Pages(4).Visible = True: MultiPage1.Pages(0).Visible = False: MultiPage1.Pages(1).Visible = False: MultiPage1.Pages(2).Visible = False: MultiPage1.Pages(3).Visible = False
End Sub
'Stop

Private Sub CommandButton3_Click()
  With Feuil9
lig = Application.Match(Label5, Feuil9.[B1:B65000], 0)
    For k = 1 To 6
    .Cells(lig, k) = MultiPage1.Pages(1).Controls("TextBox" & k) 'Métier
    Next
 .Range("G" & lig) = IIf(TextBox7 = "Non décédé", "", TextBox7)
 .Range("H" & lig) = Label14
 .Range("B" & lig) = TextBox8
  End With
lig = Application.Match(Label5, Feuil12.[A1:A65000], 0)
Feuil12.Cells(lig, 2) = TextBox9
End Sub

Private Sub CommandButton4_Click()
ListBox1.List(ListBox1.ListIndex, 1) = TextBox10
lig = Application.Match(Label5, Feuil14.[A1:A65000], 0)
Feuil14.Cells(lig, ListBox1.ListIndex + 2) = TextBox10
End Sub

Private Sub CommandButton5_Click()
ListBox2.List(ListBox2.ListIndex, 1) = TextBox11
ListBox2.List(ListBox2.ListIndex, 2) = TextBox12
lig = Application.Match(Label5, Feuil13.[A1:A65000], 0)
Feuil13.Cells(lig, ListBox2.ListIndex * 2 + 2) = TextBox11
Feuil13.Cells(lig, ListBox2.ListIndex * 2 + 3) = TextBox12
End Sub


Private Sub ListBox1_Click()
TextBox10 = ListBox1.List(ListBox1.ListIndex, 1)
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
col = ListBox1.ListIndex + 2
lig = Application.Match(Label5, Feuil14.[A1:A65000], 0)
If IsNumeric(lig) Then TextBox10 = Feuil14.Cells(lig, col)
ListBox1.Selected(ListBox1.ListIndex) = Not ListBox1.Selected(ListBox1.ListIndex)
End Sub

Private Sub ListBox2_Click()
TextBox11 = ListBox2.List(ListBox2.ListIndex, 1)
TextBox12 = ListBox2.List(ListBox2.ListIndex, 2)
End Sub


'Active les feuilles par Obption Bouton
Private Sub MultiPage1_Change()
Select Case MultiPage1.Value
  Case 0: Feuil1.Activate 'Accueil
  Case 1: Feuil9.Activate 'BdD Acteurs
  Case 2: Feuil12.Activate
  Case 3: Feuil14.Activate
  Case 4: Feuil13.Activate 'Récompenses
End Select
End Sub

'Quitter et retourner page d'accueil
Private Sub CommandButton1_Click()
Unload Me
Sheets("Accueil").Activate
End Sub

Private Sub UserForm_Activate()

' Nom de l'acteur sur la barre des titre
UsF_Stars.Caption = " Fiche de L'Acteur de..." & "  " & Label5.Caption
' Stop
End Sub

Private Sub UserForm_Initialize()
' Activer la page d'accueil
MultiPage1.Pages(0).Visible = True:
Me.MultiPage1.Value = 0 ' Activer la page d'accueil
'Stop


  Dim Rep, NomFic, sheetsUse As String
  Dim i, j As Integer
  Dim tableau() As String
 Me.MultiPage1.Value = 0
 
  If choose Then
  sheetsUse = "BdD Noms"
  Rep = "J:\Réalisateur\"
  Else
  sheetsUse = "BdD Acteurs"
  Rep = "J:\acteur\"
  End If

  With Feuil9
    ' Dans la colonne
   '   Trouver la ligne correspondante au réalisateur
'   Avec la feuille contenant les noms
lig = Application.Match(NomRéalisateur, Feuil9.[B1:B65000], 0)
' Si pas de ligne trouvée
If Not IsNumeric(lig) Then GoTo suite1
    Me.Label5.Caption = NomRéalisateur
    For k = 1 To 6
    MultiPage1.Pages(1).Controls("TextBox" & k) = .Cells(lig, k) 'Métier
    Next
   
    If .Range("G" & lig).Value <> "" Then
    MultiPage1.Pages(1).TextBox7.Value = .Range("G" & lig).Value 'Décédé le
    MultiPage1.Pages(1).Label14.Caption = .Range("h" & lig).Value 'Décédé à l'âge
    Else
    MultiPage1.Pages(1).TextBox7.Value = "Non décédé"
    End If
      MultiPage1.Pages(1).TextBox8.Value = .Range("B" & lig).Value 'Nom usuel
      MultiPage1.Pages(1).TextBox2.Value = .Range("i" & lig).Value 'Nom usuel
  End With
NomFic = Label5.Caption

suite1:
With Feuil12 'biog
'ici remplissage biographie
lig = ""
lig = Application.Match(Label5, .[A1:A65000], 0)
If Not IsNumeric(lig) Then GoTo suite2

MultiPage1.Pages(2).TextBox9 = .Cells(lig, 2)
MultiPage1.Pages(2).TextBox9.SelStart = 0
End With

suite2:
With Feuil14
lig = Application.Match(NomRéalisateur, .[A1:A65000], 0)
If Not IsNumeric(lig) Then GoTo suite3
For k = 2 To 68
ListBox1.AddItem .Cells(1, k)
ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(lig, k)
Next
End With

suite3:
With Feuil13
lig = Application.Match(NomRéalisateur, .[A1:A65000], 0)
If Not IsNumeric(lig) Then GoTo suite4
i = -1
For k = 2 To 134 Step 2
ListBox2.AddItem .Cells(1, k): i = i + 1
ListBox2.List(i, 1) = .Cells(lig, k)
ListBox2.List(i, 2) = .Cells(lig, k + 1)
Next
End With


suite4:
Image1.Visible = True
If Dir(Rep & NomFic & ".jpg") <> "" Then
    Image1.Picture = LoadPicture(Rep & NomFic & ".jpg")
Else
    Image1.Picture = LoadPicture: End If
End Sub

Merci et bonne soirée

 

[job75]

Re : Formule en VBA

Re,

Plus rien à voir avec ce fil, désolé.