ajout d'une feuille, la renommer, attribuer une valeur

Question

Bonjour, 

JMO m'a écrit une fonction qui sert à renommer les feuilles 3,4 et 5 de tous les fichiers .xls contenus dans le répertoire C:\aa2\clients.

Dans cette fonction, n'y aurait-il pas moyen, 
- de tester l'existence d'une feuille appelée " référence" 
- si la feuille "référence" n'existe pas, la créer et la nommer
- que la valeur de la cellule A1 de la feuille "référence" soit égale au nom du fichier .xls

La plus belle solution serait que ces commandes soient intégrées dans la fonction existante.
A défaut, une autre nouvelle fonction "référence" me conviendrait aussi.

Ci dessous le code écrit par JMO que je remercie encore au passage.
JL

Private Sub renamefeuilleprox_Click()
strComputer =  "."
Set objWMIService = GetObject("Winmgmts:\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * From Win32_DesktopMonitor")
For Each objItem In colItems
    intHorizontal = objItem.ScreenWidth
    intVertical = objItem.ScreenHeight
Next
Set objExplorer = CreateObject("InternetExplorer.Application")
objExplorer.Navigate "about:blank"
objExplorer.Toolbar = 0
objExplorer.StatusBar = 0
objExplorer.Left = (intHorizontal - 800) / 2
objExplorer.Top = (intVertical - 100) / 2
objExplorer.Width = 500
objExplorer.Height = 180
objExplorer.Visible = 1
objExplorer.Document.Body.Style.Cursor = "wait"
objExplorer.Document.Title = fic & "  -  " & Now
objExplorer.Document.Body.InnerHTML = "
Traitement des fichiers PROXIMUS
""" & fic & """
en cours , merci de patienter.
"


Dim path: path = "C:\aa2\Clients"
objExplorer.Document.Body.Style.Cursor = "default"
objExplorer.Quit
Set objExplorer = Nothing
Set colItems = Nothing
Set objWMIService = Nothing



 Call ShowFolderListprox(path) 




End Sub


*********************************************************
Function ShowFolderListprox(path)
Dim fso:        Set fso  = CreateObject("Scripting.FileSystemObject")
Dim Dossiers:   Set Dossiers = fso.GetFolder(path)
Dim fichiers:   Set fichiers = Dossiers.Files


Dim fichier, f, strListe


For Each fichier In fichiers
    Set f = fso.GetFile(fichier)
    If fso.GetExtensionName(fichier) = "xls" Then
       Dim objExcel, objClasseur
       Set objExcel = CreateObject("Excel.Application")
       Set objClasseur = objExcel.Workbooks.Open(fichier)


       objExcel.DisplayAlerts = False 'enlève l'alerte
       objExcel.Application.Visible = False
     
      'MsgBox objClasseur.Sheets(1).Name,,"Nom de la Feuil1 avant modification"
      objClasseur.Sheets(3).Name = "ident1"
      objClasseur.Sheets(4).Name = "ident2"
      objClasseur.Sheets(5).Name = "ident3"
           
      'WScript.Sleep "500"
      'MsgBox objClasseur.Sheets(1).Name,,"Nom de la Feuil1 après modification"
      objExcel.ActiveWorkbook.SaveAs fichier 'sauvegarde sous le même nom
      objExcel.ActiveWorkbook.Saved = True 'sauvegarde true=oui false=non
      'objExcel.DisplayAlerts=True 'remet l'alerte
      'objExcel.Application.Visible=True 'remet la visibilité
      objExcel.ActiveWorkbook.Close 'Fermeture d'Excel


     
      Set objExcel = Nothing
      Set objClasseur = Nothing
   End If
Next
Set f = Nothing
Set fichiers = Nothing
Set Dossiers = Nothing
Set fso = Nothing


End Function

jrivet · Answer

Salut, Utilises cette fonction Private Function WorksheetExists(ByVal WorkSheetName As String) As Boolean On Error GoTo HandleError 'On essaie d'activer la feuille portant le nom contenu 'dans WorkSheetName Call ActiveWorkbook.Worksheets(WorkSheetName).Activate WorksheetExists = True Exit Function HandleError: 'si elle n'existe pas alors il y aura une exception On Error GoTo 0 End Function Coloration syntaxique automatique [AFCK] Ensuite la ou tu veux effectuer le test tu place le code suivant 'Objet Feuille si necessaire Dim NewSheet As Worksheet 'Si la feuille n'existe pas If Not WorksheetExists("Reference") Then 'Ajout de la feuille dans le classeur actif Set NewSheet = ActiveWorkbook.Worksheets.Add With NewSheet 'Selectionne la nouvelle feuille .Activate 'La renomme .Name = "Reference" End With End If 'PLace dans la Cellule A1 le nom du classeur actif ActiveWorkbook.ActiveSheet.Range("A1") = ActiveWorkbook.Name Coloration syntaxique automatique [AFCK] Voila j espere que cela va fonctionner et resoudre ton probleme @+, Ju£i?n

jeanluc065 · Answer

Merci Julien, 

Mais c'est très compliqué et à première vue, je ne vois pas comment je vais m'y prendre car je suis hyper novice ?
Merci pour ton aide, je vais essayer.

jrivet · Answer

Re,


C'est pas plus compliqué que le bout de code que tu as mis dans ton premier post.


Et puis nous sommes toujours la si cela coince.


En revanche j'ai fait ce code en VBA Excel. tu es en quoi?






@+,   Ju£i?n

jeanluc065 · Answer

Re Julien, 


En fait je dois faire tout çà depuis access 2002.
C'est peut-être pas plus compliqué, mais c'est JMO qui l'é écrit, j'en aurais été incapable.
Je vais essayer d'attaquer çà demain mais ............!
merci

Ajout d'une feuille, la renommer, attribuer une valeur

4 réponses

Votre réponse

Discussions similaires