Discussion :

[Pierre Schwab]

Bonjour, a tous



je souhaitais modifier une vba que j'ai glaner sur le web

mais ne m'y connaissant pas assez et que le code n'est pas ultra clair par apport a mes connaissance, je me trouve bloquée dans celle que j'ai trouvé.
But de l'opération renommé des fichiers qui ont aucun type de fichier exemple des (.txt;.xls;etc), et ajouter le xls

Voici un code qui fonctionne.
sur la feuil "BDD" l'ancien nom de fichier et le nouveau nom a récupérer.
Je souhaiterais modifier l'ouverture du dossier ou les fichiers sont a renommer.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Public ReponseMsgBox As Variant
Public Const NoDeLaPremLigAvecNoms = 2
Public Const NoDeColDesFichiersOLD = 11
Public Const NoDeColDesFichiersNEW = 12
Public Const NoDeColDesFichiersREN = 13
' , &H1&)=avec bouton "créer un nouveau dossier" ... , $H201&)=sans le bouton
'objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&, RepDefaut)
Public Function FLoadNomDuREP() As String
Dim objShell As Object, objFolder As Object, REP As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un dossier", &H201&)
If Not objFolder Is Nothing Then
   REP = objFolder.Items.Item.Path
   If Right(REP, 1) <> "\" Then REP = REP & "\"
End If
FLoadNomDuREP = REP
Set objShell = Nothing: Set objFolder = Nothing
End Function
 
 
Public Sub Rendre_lisible_les_fichiers_de_mesure_renomage()
Dim Chemin$, NoDeLaDernLigAvecNoms%
Chemin = FLoadNomDuREP: Chemin = Trim(Chemin): If Chemin = "" Then Exit Sub
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
M$ = "Renommer les fichiers dans le répertoire:" & vbLf & Chemin & vbLf & vbLf & "Veuillez confirmer ?"
ReponseMsgBox = MsgBox(M$, vbQuestion + vbYesNo, "renommer")
If ReponseMsgBox <> vbYes Then Exit Sub
 
Sheets("BDD").Select
NoDeLaDernLigAvecNoms = Columns(NoDeColDesFichiersOLD).Rows(ActiveSheet.Rows.Count).End(xlUp).Row 'dern.lig.noms
Range(Cells(NoDeLaPremLigAvecNoms, NoDeColDesFichiersREN), Cells(NoDeLaDernLigAvecNoms, NoDeColDesFichiersREN)) = ""
On Error Resume Next
For Lig = NoDeLaPremLigAvecNoms To NoDeLaDernLigAvecNoms
 FichOLD$ = Cells(Lig, NoDeColDesFichiersOLD)
 FichNEW$ = Cells(Lig, NoDeColDesFichiersNEW)
 If FichOLD$ > "" Then
    If FichNEW$ > "" Then
       Err.Clear: Name Chemin & FichOLD$ As Chemin & FichNEW$ 'renomme
       If Err = 0 Then
          Cells(Lig, NoDeColDesFichiersREN) = "Modifier ok"
       Else
          Cells(Lig, NoDeColDesFichiersREN) = "Fichier absent / mauvais nom rappel C1 SAM C2 SIAM"
          Msg$ = "Fichier source: " & FichOLD$ & vbLf & _
          "Fichier destin: " & FichNEW$ & vbLf & vbLf & _
          "Erreur " & Err.Source & "  No " & Err.Number & vbLf & vbLf & Err.Description
          MsgBox Msg$, vbCritical, "Erreur Renomme", Err.HelpFile, Err.HelpContext
       End If
    Else
       Cells(Lig, NoDeColDesFichiersREN) = "Fichier absent / mauvais nom rappel C1 SAM C2 SIAM"
       MsgBox "Aucun nom de fichier NEW devant le fichier OLD > " & FichOLD$
    End If
 End If
 
 End Sub

voici le code que je souhaiterai mettre, ce qui permettra de modifier la boite de dialogue qui sélectionne le dossier ou les fichiers sont enregistrer.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
'*******************************'
'* Récupérer_les_données Macro *'
'*******************************'
 
Sub RECUPERER_LES_DONNEES()
 
'*********************************************'
'*  Evite l'erreur supprimer dernière ligne  *'
'*  si il n'y a rien a supprimmer            *'
'*********************************************'
 
On Error Resume Next
 
'********************************************'
'*  Pour éviter les alertes lors des copies *'
'********************************************'
 
Application.DisplayAlerts = False
 
'********************************************************'
'* Code pour choisir manuellement                       *'
'* le répertoire dans lequel se trouveront les mesures  *'
'********************************************************'
 
NomRepertoire = ""
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then
'**********************************************'
'* ouvre laMsgBox Repertoire.SelectedItems(1) *'
'**********************************************'
    NomRepertoire = Repertoire.SelectedItems(1)
Else
    MsgBox "Aucun Répertoire Sélectionné !"
End If
 
'************************************************************'
'*  Récupère l'adresse d'enregistrement du fichier actuel   *'
'*   'ChDir  Workbooks(ActiveWorkbook.Name).Path            *'
'************************************************************'
 
If NomRepertoire <> "" Then
 
    ChDir (NomRepertoire)
 
 
'**************************************************'
'*  Ne pas mettre a jour l'affichage              *'
'*  Auguemente la vitesse d'execution de la macro *'
'**************************************************'
 
  Application.ScreenUpdating = False

d'avance je vous remercie.
PES

version d'office : Excel 2013

[Pierre Schwab]

Bonjour a tous,

Je me demande si je me suis bien exprimer, ou est-ce trop complexe??

D'avance merci du retour de chacun.