fichiers qui effacent les autres dans macro ?

[alucard_xs]

boucle qui écrase des fichiers deja présents

Bonjour,

voilà j'ai continuer mon programme mais j'ai un soucis, j'explique :

dans mon programme, via un bouton, j'applique une grosse macro qui va couper les fichiers se trouvant dans le repertoire indiqué dans la cellule A3 dans le repertoire "excel", puis crée, s'ils n'existent pas deux autres répertoires, le probleme, c'est que si par exmple, je remet des nouveaux fichiers dans le repertoire de départ, et que j'execute la macro, mon programme me supprime les fichiers déjà crées ... comment faire ?

Merci, voici mon code

Private Sub CommandButton9_Click()

If Worksheets("Feuil1").Cells(3, 1).Value <> "" Then


nomRep1 = Worksheets("Feuil1").Cells(3, 1).Value & "\" & "Données "
Nomrep2 = Worksheets("Feuil1").Cells(3, 1).Value & "\" & "Fiches El"
Nomrep3 = Worksheets("Feuil1").Cells(3, 1).Value & "\" & "Fiches P"
If Len(Dir(Worksheets("Feuil1").Cells(3, 1).Value & "\" & "Données", vbDirectory)) = 0 Then
MkDir nomRep1
MkDir Nomrep2
MkDir Nomrep3
End If
'End If

'Définition des variables

Dim oFSO As Scripting.FileSystemObject
Dim chemin_et_fichier As String
Dim fichier_demo As String
Dim ws As Worksheet

Dim sCurPrinter As String


Set oFSO = New Scripting.FileSystemObject
oFSO.MoveFile Worksheets("Feuil1").Cells(3, 1).Value & "\*.xls", nomRep1
nomfichier = Dir(nomRep1 & "\*.xls")
fichier1 = "D:\ghr02q\Privé\1.xls"
fichier2 = "D:\ghr02q\Privé\2.xls"
Application.ScreenUpdating = False
Dim nouvo_fichier As String
Dim chemin_et_nouveau_fichier As String


While nomfichier <> ""
    
    chemin_et_fichier = nomRep1 & "\" & nomfichier
    Dim CL1 As Workbook
    Dim CL2 As Workbook
    
    Workbooks.Open (chemin_et_fichier)
    DoEvents
    Set CL1 = ActiveWorkbook
    
    'changement de fiche 
    If Len(ActiveWorkbook.Name) = 12 Then
    Workbooks.Open (fichier1)
    Else: Workbooks.Open (fichier2)
    End If
   
    DoEvents
    Set CL2 = ActiveWorkbook
    CL1.Worksheets(1).Range("A1:CG36").Copy CL2.Worksheets("RP-CAFn-CAFn-1").Range("A1")
    DoEvents
    ActiveWorkbook.SaveAs Filename:=Nomrep2 & "\" & "f_" & nomfichier, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    DoEvents
    nouvo_fichier = "f_" & nomfichier
    chemin_et_nouveau_fichier = Nomrep2 & "\" & nouvo_fichier
    
    
    'Impression sur imprimante virtuelle en .ps (postscript)
    Application.ActivePrinter = "Adobe PDF sur NE00:"
    ActiveWorkbook.Worksheets(1).PrintOut copies:=1, PrintToFile:=True, ActivePrinter:="Adobe PDF sur NE00:", prtofilename:=Nomrep3 & "\" & nomfichier & ".ps"
    Application.ActivePrinter = "\\s56slin\RICOH 3030 SED sur Ne02:"
    
    Set CL1 = Nothing
    Set CL2 = Nothing
    
    Set wbkFichier = Workbooks.Open(Filename:=chemin_et_fichier)
        wbkFichier.Close savechanges:=False
        
    Set wbkFichier2 = Workbooks.Open(Filename:=chemin_et_nouveau_fichier)
        wbkFichier2.Close savechanges:=False
               
    nomfichier = Dir
    
    
Wend


MsgBox "terminée"

Else: MsgBox "veuillez choisir un répertoire de travail"
End If
End Sub

de plus concernant ce bout de code :

If Len(ActiveWorkbook.Name) = 12 Then
    Workbooks.Open (fichier1)
    Else: Workbooks.Open (fichier2)
    End If

comment lui dire voila, si le nom du fichier ouvert = 12 alors tu m'ouvres fichier1, par contre si nom du fichier ouvert = 'lalala.xls" ou 'lalala2.xls" ou "lalala3.xls" alors tu m'ouvres fichier2 et enfin si nomfichier ouvert différent de 12 ou différent des 3 fichiers nommés ci dessus alors tu m'ouvre "fichier3.xls" ?

Merci à tous

 

[alucard_xs]

Re : fichiers qui effacent les autres dans macro ?

arf personne n'a compris mes deux questions ?
bon la deuxième, c'est juste une condition finalement, la premiere, je suspecte ça finalement

Set oFSO = New Scripting.FileSystemObject
oFSO.MoveFile Worksheets("Feuil1").Cells(3, 1).Value & "\*.xls", nomRep1
nomfichier = Dir(nomRep1 & "\*.xls")

 

[alucard_xs]

Re : fichiers qui effacent les autres dans macro ?

dans mon prog:

1) il coupe le fichier et le met dans un repertoire \données
il fait sa cuisine mais le soucis c'est que si je remet un autre fichier dans le repertoire et que je relance la macro, il me dit qu'il va écraser celui qui se trouve dans \données, et pourtant c'est pas le même nom ...

 

[alucard_xs]

Re : fichiers qui effacent les autres dans macro ?

bon je pense savoir d'où vient mon erreur de fichiers ... par contre si qq1 pouvait me dire comment écrire ma questioun 2, si la condtion ça serait bien sympa

 

[fred65200]

Re : fichiers qui effacent les autres dans macro ?

bonjour alucard_xs,

Je n'ai pas tout compris pour tes explications de la 2nde partie de ton post (len(...) = 12 vs 12).

À tout hasard, je te joins un code qui permet d'ouvrir le "classeur suivant".

Si Classeur1 est ouvert, on ouvre Classeur2.
Si Classeur1 et Classeur2 sont ouverts, on ouvre Classeur3.
Si Classeur1, Classeur2 et Classeur3 sont ouverts, on ouvre Classeur4.
Si Classeur1, Classeur2, ........., et Classeur(N) sont ouverts, on ouvre Classeur(N+1) (s'il existe).

Sub OuvrirFichierSuivant()
Dim Racine, NomFichier, Ext, FichierSuivant As String
Dim No As Integer
Dim fso As Object

Racine = "C:\Users\xxxx\Desktop\"
NomFichier = "Classeur"
Ext = ".xls"
No = 0

Set fso = CreateObject("Scripting.FileSystemObject")

'on compte les classeurs ouverts qui commence par "NomFichier"
For Each Wd In Windows
  If Left(Wd.Caption, 7) = NomFichier Then No = No + 1
Next

'le numéro du classeur suivant  = No + 1
FichierSuivant = Racine & NomFichier & No + 1 & Ext
 
'on vérifie que FichierSuivant existe.
If fso.FileExists(FichierSuivant) Then
 's'il existe, on l'ouvre
 Workbooks.Open FichierSuivant
Else: MsgBox FichierSuivant & " n'existe pas!": End
End If
End Sub

Certainement à adapter.
Cordialement
fred65200