VBA Création automatique d'une nouvelle fiche

Bonjour,

J'ai un projet à mon travail je procède à l'ouverture de projet et je souhaite automatiser le tout.

Voici le portrait de mon projet. J'ai un tableau avec les noms de projets en cours et certaine données que je souhaite recopier dans une autre feuille excel qui nous sert de page titre pour l'ouverture physique du projet.

Voici ce que j'aimerais:

- Créer une nouvelle feuille à l'aide d'un bouton et de ma page modèle projet.
- Bref, Je veux qu'à toute les fois que je créer un nouveau projet dans le tableau les informations ce copie dans une nouvelle feuille à partir du modèle. Mais cette feuille ne dois pas se créer en double
- J'ai donc penser ajouter une colonne intitulé ouverture. Les projets indiquant ok dans la colonne ''ouverture'' ne devront pas recréer de fiche.
- Les informations qui doivent se transférer dans mon modèles sont le nom du projet, la date, le numéro ACQ.
- J'aimerais aussi que le nom des nouvelles feuilles créer portes des noms différent en fonction de si le projet est en architecture ou en mécanique .

J'ai commencer un code qui créer ma nouvelle feuille modèle mais qui ne copie pas les informations et qui créer uniquement 1 feuille à la fois.

Le voici:

Private moShListing As Worksheet

Public Sub CreerToutesFiches()

Dim iLigDeb As Integer
Dim iLigFin As Integer
Dim iLig As Integer

Set moShListing = Worksheets("Liste projet")

iLigDeb = 2
iLigFin = Range("A" & Rows.Count).End(xlUp).Row

For iLig = iLigDeb To iLigFin
CREATIONFICHEPROJET iLig
Next iLig

Set moShListing = Nothing

End Sub

'Sub CREATIONFICHEPROJET()
Private Sub CREATIONFICHEPROJET(piLig As Integer)

'
' CREATIONFICHEPROJET Macro
' création d'une fiche projet
'
Dim oSh As Worksheet
Dim sNom As String
Dim bOngletExist As Boolean

sNom = moShListing.Range("A" & piLig).Value

bOngletExist = OngletExist(sNom)

If bOngletExist Then
'si l'onglet existe déjà, on ne le recrée pas
Set oSh = Worksheets(sNom)
Else
'Création onglet
Worksheets("modèle projet").Copy Before:=Worksheets(Sheets.Count)

Set oSh = Worksheets("modèle projet (2)")
End If

oSh.Name = sNom
oSh.Range("$B$10:$E$10").Value = moShListing.Range("D" & piLig).Value 'Projet:
oSh.Range("D5").Value = moShListing.Range("G" & piLig).Value 'Date:
oSh.Range("B13").Value = moShListing.Range("C" & piLig).Value '# ACQ:


'cadre
'Range("C3:G3").Select
moShListing.Range("C" & piLig & ":G" & piLig).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

Set oSh = Nothing

End Sub

Private Function OngletExist(psNom As String) As Boolean

Dim oSh As Worksheet
Dim lErr As Long
Dim sErr As String

On Error Resume Next
Set oSh = Worksheets(psNom)
lErr = Err.Number
sErr = Err.Description
On Error GoTo 0

If lErr = 0 Then
OngletExist = True
ElseIf lErr = 9 Then
OngletExist = False
Else
MsgBox "Erreur n°" & lErr & vbCrLf & sErr, vbExclamation
End If

Set oSh = Nothing

End Function


*


*

Par ailleurs il est à noté que la colonne ouverture sera la colonne ''H''. C'est la colonne qui servira à savoir si le projet à déjà été ouvert ou non.

Voir mon élaboration de code que j'aimerais intégrer au code précédent.


' boucle sur lignes de projet
For n = 2 To LigneD
'si ok copie ligne
If Sheets("Liste projet").Range("H" & n) = "ok" And Sheets("Liste projet").Range("I" & n) = "" Then

Sheets("Liste projet").Select
ActiveSheet.Range("A" & n & ":I" & n).Select
Selection.Copy
Sheets("modèle projet").Select


'et colle dans modèle projet
Sheets("modèle projet").Range("A" & ligneA).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' remplace ok par Ouvert
Sheets("Liste projet").Range("I" & n) = "Ouvert"
'incremente variable x (nbre d'ouverture faite)
x = x + 1

End If

Next n
If x = 0 Then MsgBox "Il n'y a rien à ouvrir" Else MsgBox "Ouverture de projet terminé de " & x & " lignes"

End Sub

End If


Je ne suis pas capable de tester si cette partie fonctionne.

Je vous remercie en avance de votre aide.