Saiise de Jour identique

[Loulou]

Bonjour le forum

J'ai fais un programme qui recense les actions d'intervention des pompiers.
Le pompier saisie l'intervention et lorsqu'il valide cella génère un onglet avec la date d'intervention
Jusqu'à là tout va bien.
Mon problème porte s'il y a deux ou trois interventions le même jour.
Je souhaiterais si c'est possible que la première saisie l'onglet se nomme 27/09/06 et si il y a une autre saisie le même jour l'onglet se nomme 27/09/06_1 sur ainsi de suite 27/09/06_2.

Voici mon code

Sub Evenement2(ByVal nom As String)

' maj le 26/09/2006 CAMPELLO Hervé 233534

Sheets("Vierge").Select
Sheets("Vierge").Copy after:=Sheets("Vierge")
Sheets("Vierge (2)").Select
While ActiveSheet.Shapes.Count - 1 > 0
i = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Delete
Wend

Sheets("Vierge (2)").Name = ca
Range("a2").Select
Sheets("Vierge").Select
Call Miseazero
MsgBox "La nouvelle feuille de " & Sheets("Vierge").Cells(2, 14) & " est prête"
Sheets("Param").Select
F = Cells(2, 9).Value
LienCellule (F)
Sheets("Accueil").Select

End Sub

Sub Evenement1()
ca = Format(Sheets("Vierge").Cells(118, 2), "dd_mm_yy")
Evenement2 (ca)
End Sub


Merci pour votre aide.

Loulou

 

[Hervé]

Re : Saiise de Jour identique

bonjour

une proposition à travers une fonction pour retrouver le dernier numéro d'intervention:

code non testé.

Public Function recherchenum(ByVal ca As String) As Integer
Dim ws As Worksheet
Dim tablo
Dim max As Integer

For Each ws In Worksheets
    If InStr(1, ws.Name, ca) = 1 Then
        tablo = Split(ws.Name, "_")
        If max < tablo(UBound(tablo)) Then max = tablo(UBound(tablo))
    End If
Next ws

recherchenum = max
End Function

Sub Evenement2(ByVal nom As String)

' maj le 26/09/2006 CAMPELLO Hervé 233534

Sheets("Vierge").Select
Sheets("Vierge").Copy after:=Sheets("Vierge")
Sheets("Vierge (2)").Select
While ActiveSheet.Shapes.Count - 1 > 0
i = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Delete
Wend

Sheets("Vierge (2)").Name = ca & "_" & recherchenum(ca) + 1
Range("a2").Select
Sheets("Vierge").Select
Call Miseazero
MsgBox "La nouvelle feuille de " & Sheets("Vierge").Cells(2, 14) & " est prête"
Sheets("Param").Select
F = Cells(2, 9).Value
LienCellule (F)
Sheets("Accueil").Select

End Sub

Sub Evenement1()
ca = Format(Sheets("Vierge").Cells(118, 2), "dd_mm_yy")
Evenement2 (ca)
End Sub

salut

 

[PascalXLD]

Re : Saiise de Jour identique

Bonjour

essaie ainsi

Sub Evenement1()
dim ws as worksheet
dim monnbre as byte
ca = Format(Sheets("Vierge").Cells(118, 2), "dd_mm_yy")
for each ws in worksheets
if left(ws.name,8)=ca then monNbre=monnbre+1
next
if monnbre>0 then ca=ca & "_" & monnbre
Evenement2 (ca)
End Sub


Edit : Oups excuse Hervé pas raffraichi
Loulou a 2 possibilités ainsi
Bonne journée à toi

 

[sousou]

Re : Saiise de Jour identique

Bonjour à tous
J'ai modifier ton code et ajouter une fonction
Attention j'ai modifier des chose qui ne concernaient pas le problème

Dim ca
Sub Evenement2(ByVal nom As String)

' maj le 26/09/2006 CAMPELLO Hervé 233534

Sheets("Vierge").Select
Sheets("Vierge").Copy after:=Sheets("Vierge")
Sheets("Vierge (2)").Select
While ActiveSheet.Shapes.Count - 1 > 0
i = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(i).Delete
Wend

Sheets("Vierge (2)").Name = test(ca)
Range("a2").Select
Sheets("Vierge").Select
'Call Miseazero
'MsgBox "La nouvelle feuille de " & Sheets("Vierge").Cells(2, 14) & " est prête"
'Sheets("Param").Select
'F = Cells(2, 9).Value
'LienCellule (F)
'
End Sub

Sub Evenement1()
ca = Format(Sheets("Vierge").Cells(1, 2), "dd_mm_yy") 'Modification de la cellule à remettre pour topn appli
Evenement2 (ca)
End Sub
Function test(d)
b = d
k = 0
While k = 0
k = 1
For Each i In Sheets

c = 0
If i.Name = b Then
k = 0
n = Len(b) - InStrRev(b, ".", -1)
If n = 8 Then
c = 1
Else
c = Val(Right(b, n)) + 1
End If
b = ca & "." & c
Exit For

End If
Next


Wend
test = b

End Function