Enregistrement d'une plage de cellule dans nouveau fichier

Le 31/03/2015 à 15:07

Bonjour à tous,

Je rencontre un petit soucis avec un code que j'ai fais sur un fichier (enfin code que j'ai repris sur internet et adapté), qui enregistre une place de donnée sélectionnée dans un nouveau fichier excel. Le soucis est que ce fichier de base est utilisé sur plusieurs PC, et le chemin d'accès au dossier d'enregistrement est différent, donc je ne peux pas le fixer...

J'aimerai donc faire une sorte de "Fichier - enregistrer sous" à partir de mon programme pour demander à utilisateur d'indiquer le dossier dans lequel il veut enregistrer le nouveau fichier, pour que ce soit possible de le faire de n'importe quel PC sans à chaque fois changer dans le code le chemin ! Tout ceci si possible en gardant le nom déjà imposé ("BL_xxxxx").

Voici mon code :

Sub ColleEtSauve()
Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
Set MaPlage = S_WKB.Sheets("BL").Range("A1:H59")

NumBL = Sheets("BL").Range("A11").Value

Chemin = "Z:\BONS DE LIVRAISON\"
NFic = "BL_" & NumBL
Application.ScreenUpdating = False
MaPlage.Copy
Set D_WKB = Workbooks.Add(xlWBATWorksheet)
With D_WKB.ActiveSheet
    .Paste
        With .UsedRange
            .Value = .Value
        End With
End With
Application.CutCopyMode = False
D_WKB.SaveAs Chemin & NFic
D_WKB.Close True
Application.ScreenUpdating = True
End Sub

Merci de votre aide !

Le 31/03/2015 à 18:41

Bonjour

voici une fonction que j'avais trouvé et modifié il y a quelque temps qui demande a l'utilisateur de choisir un dossier, ce qui correspondra a votre chemin d'enregistrement

a adapter a votre version d'excel

fred

 Function ChoixDossier()
 'http://www.excel-pratique.com/fr/astuces_vba/action_differente_selon_version_excel.php
    If Val(Application.Version) >= 12 Then ' verifie que la version d'excel est supérieure ou égale à la version 2007
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     End If
End Function
Le 01/04/2015 à 09:14

Bonjour,

Finalement j'ai trouvé une solution intermédiaire et plus rapide : comme le fichier est utilisé par deux utilisateurs, je demande avec une MsgBox lors de la sauvegarde quel utilisateur est-ce, pour définir correctement le lien de sauvegarde. Voici le code :

Sub ColleEtSauveII()

Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
Set MaPlage = S_WKB.Sheets("BL").Range("A1:H59")

    If MsgBox("Etes-vous sur le PC d'Ilvana ?", vbYesNo, "Demande de confirmation") = vbYes Then

            Chemin = "E:\LMScommun\BONS DE LIVRAISON"

         MsgBox "Le fichier a bien été sauvegardé !"

    Else

            Chemin = "Z:\BONS DE LIVRAISON\"
            MsgBox "Le fichier a bien été sauvegardé !"

    End If

NumBL = Sheets("BL").Range("A11").Value
NFic = "BL_" & NumBL
Application.ScreenUpdating = False
MaPlage.Copy
Set D_WKB = Workbooks.Add(xlWBATWorksheet)
With D_WKB.ActiveSheet
    .Paste
        With .UsedRange
            .Value = .Value
        End With
End With
Application.CutCopyMode = False

D_WKB.SaveAs Chemin & NFic
D_WKB.Close True
Application.ScreenUpdating = True

End Sub

Simplement j'aurais bien voulu rajouter une partie pour un fichier qui a déjà été enregistré : j'aimerai que lorsque le nom existe déjà, il sauvegarde automatiquement le fichier sous le même nom mais en rajoutant la date du jour et l'heure à côté, exemple :

-> le nom BL_11035 est déjà pris, il enregistre donc automatiquement le fichier en "BL_11035_ 01.04.2015_ 09h20"

Je ne vois pas comment définir la condition "Si fichier déjà existant", alors si quelqu'un pourrais m'aider...

Merci à tous !

Victorien

Le 01/04/2015 à 10:21

BOnjour

avec la fonction DIR

'renvoi le nom du fichier si il existe sinon ""
    test_existance_fichier = Dir(Fichier)

la variable fichier doit contenir le chemin + nom du fichier

Fred

Le 01/04/2015 à 11:25

Bonjour, j'ai essayé ça mais ce ne fonctionne pas :

Sub ColleEtSauveII()

Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
Set MaPlage = S_WKB.Sheets("BL").Range("A1:H59")

    If MsgBox("Etes-vous sur le PC d'Ilvana ?", vbYesNo, "Demande de confirmation") = vbYes Then

            Chemin = "E:\LMScommun\BONS DE LIVRAISON\"

         MsgBox "Le fichier a bien été sauvegardé !"

    Else

            Chemin = "Z:\BONS DE LIVRAISON\"
            MsgBox "Le fichier a bien été sauvegardé !"

    End If

NumBL = Sheets("BL").Range("A11").Value
NFic = "BL_" & NumBL

'Si nom déjà existant
If Dir(NFic) <> "" Then

    'On rajoute la date et l'heure dans le nom
    jour = Format(Now, "dd-mm-yy_hh.mm.ss")
    NFic = "BL_" & NumBL & jour
    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .Paste
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

'Sinon on enregistre comme ça
Else

    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .Paste
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

End If

End Sub
Le 01/04/2015 à 11:59

bonjour

c'est bien le test qui ne fonctionne pas ???

car la fonction DIR attend le chemin+nom fichier, comme dis précédemment

essayé avec :

If Dir(chemin & NFic & ".xlsx") <> "" Then

fred

Le 01/04/2015 à 15:13

Oui c'était effectivement cela, merci

J'ai et voici le code final :

Sub ColleEtSauveII()

Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
Set MaPlage = S_WKB.Sheets("BL").Range("B1:I59")

NumBL = Sheets("BL").Range("B11").Value
NFic = "BL_" & NumBL

    If MsgBox("Etes-vous sur le PC d'Ilvana ?", vbYesNo, "Demande de confirmation") = vbYes Then

            Chemin = "E:\LMScommun\BONS DE LIVRAISON\"
            Nom = "E:\LMScommun\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    Else

            Chemin = "Z:\BONS DE LIVRAISON\"
            Nom = "Z:\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    End If

'Si nom déjà existant

If Dir(Nom) <> "" Then

    'On rajoute la date et l'heure dans le nom
    jour = Format(Now, "dd-mm-yy") & "_" & Format(Now, "hh") & "h" & Format(Now, "mm") & " " & Format(Now, "ss") & "s"
    NFic = "BL_" & NumBL & "_" & jour
    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .Paste
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

'Sinon on enregistre comme ça

Else

    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .Paste
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

End If

MsgBox "Le fichier a bien été sauvegardé !"

End Sub

Par contre dernier soucis : dans le fichier de copie qui est créé à chaque fois, on ne retrouve pas les valeurs qui sont sur le fichier original puisque les cellules sont remplies grâce a des formules, j'aimerai que ce soit uniquement les valeurs de cellules et non les formules qui soient copiées...

J'ai tenté :

Set MaPlage = S_WKB.Sheets("BL").Range("B1:I59").Value

mais ça ne fonctionne pas...

Le 01/04/2015 à 16:50

un essai avec paste special

PasteSpecial xlPasteValues

fred

Le 02/04/2015 à 10:00

Déjà testé mais le programme plante, il accepte pas...

Sub ColleEtSauveII()

Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
Set MaPlage = S_WKB.Sheets("BL").Range("B1:I59")

NumBL = Sheets("BL").Range("B11").Value
NFic = "BL_" & NumBL

    If MsgBox("Etes-vous sur le PC d'Ilvana ?", vbYesNo, "Demande de confirmation") = vbYes Then

            Chemin = "E:\LMScommun\BONS DE LIVRAISON\"
            Nom = "E:\LMScommun\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    Else

            Chemin = "Z:\BONS DE LIVRAISON\"
            Nom = "Z:\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    End If

'Si nom déjà existant

If Dir(Nom) <> "" Then

    'On rajoute la date et l'heure dans le nom
    jour = Format(Now, "dd-mm-yy") & "_" & Format(Now, "hh") & "h" & Format(Now, "mm") & " " & Format(Now, "ss") & "s"
    NFic = "BL_" & NumBL & "_" & jour
    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .PasteSpecial Paste:=xlPasteValues
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

'Sinon on enregistre comme ça

Else

    Application.ScreenUpdating = False
    MaPlage.Copy
        Set D_WKB = Workbooks.Add(xlWBATWorksheet)
            With D_WKB.ActiveSheet
                 .PasteSpecial Paste:=xlPasteValues
                With .UsedRange

                .Value = .Value

                End With

            End With

    Application.CutCopyMode = False

    D_WKB.SaveAs Chemin & NFic
    D_WKB.Close True
    Application.ScreenUpdating = True

End If

MsgBox "Le fichier a bien été sauvegardé !"

End Sub
Le 02/04/2015 à 10:41

bonjour il faut faire le collage en indiquant une cellule a partir de laquelle le collage doit être fait,

par exemple :

.Range("A1").PasteSpecial Paste:=xlPasteValues

fred

Le 02/04/2015 à 12:21

Bon finalement comme c'était trop complexe, j'ai changé totalement mon code, pour séparer le copiage de la sauvegarde, et pas tout faire en même temps !

Je t'explique, le Range("B1:I59") que je dois copier est un bon de livraison, en gros je dois le copier en entier, et le coller sur mon nouveau classeur pour garder la forme, les images, ... , et ensuite je dois copier le Range("B17:I50") où sont contenus les numéros des pièces (qui sont obtenus avec des formules donc) afin de pouvoir les coller avec le PasteSpecial xlPasteValues (pour garder que les numéros et pas les formules).

Pour ça la manip est la suivante :

  • Copier le Range 1
  • Ouvrir un nouveau classeur et y coller le Range 1
  • Reprendre le Classeur "BL" et copier le Range 2
  • Réactiver le nouveau classeur précédent et y coller le Range 2
  • Enregistrer le nouveau classeur selon le nom de l'utilisateur et divers autres paramètres

La dernière manip fonctionne, tout le reste plante...

Voilà mon code :

Sub ColleEtSauve()
'
Dim MaPlage As Range

NumBL = Sheets("BL").Range("B11").Value
NFic = "BL_" & NumBL 'Variable qui prend la date du jour format aaaa-m-j
Set MaPlage = Sheets("BL").Range("B1:I59") 'Applique la plage voulue à la variable, changer le range pour changer la plage
Set MaPlagePièces = Sheets("BL").Range("B17:I50")

    MaPlage.Copy 'Fait la copie de la zone voulue
    Workbooks.Add 'Ouvre un nouveau Fichier XL
    ActiveSheet.Paste 'Colle la sélection à copier sur la feuille active, donc la nouvelle
    Workbooks("BL CLAAS 2015.xlsm").Activate
    Worksheets("BL").Activate
    MaPlagePièces.Copy
    Workbooks("Classeur1").Activate
    Worksheets("Feuil1").Activate
    Worksheets("Feuil1").Range("A17").PasteSpecial Paste:=xlPasteValues

  ' Manip de sauvegarde :

    If MsgBox("Etes-vous sur le PC d'Ilvana ?", vbYesNo, "Demande de confirmation") = vbYes Then

            Chemin = "E:\LMScommun\BONS DE LIVRAISON\"
            Nom = "E:\LMScommun\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    Else

            Chemin = "Z:\BONS DE LIVRAISON\"
            Nom = "Z:\BONS DE LIVRAISON\" & "BL_" & NumBL & ".xlsx"

    End If

    'Si nom déjà existant
    If Dir(Nom) <> "" Then

    'On rajoute la date et l'heure dans le nom
    jour = Format(Now, "dd-mm-yy") & "_" & Format(Now, "hh") & "h" & Format(Now, "mm") & " " & Format(Now, "ss") & "s"

    ActiveWorkbook.SaveAs Filename:= _
        Nom & jour, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    'Sinon on laisse
    Else

    ActiveWorkbook.SaveAs Filename:= _
        Nom, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False

    End If

MsgBox "Le fichier a bien été sauvegardé !"
Le 02/04/2015 à 16:57

Bonjour

pour me permettre de t'aider il me faudrait un fichier avec une feuille modele cela sera plus simple.... (rendre anonyme les données

de plus si je comprends bien tu copie une feuille en entier et tu transfert uniquement les valeurs dans un deuxième temps c'est ca ?

fred

Le 03/04/2015 à 08:49

Bonjour Fred, oui c'est exactement ça ! Je te prépare une feuille similaire avec données cachée, et je t'envoi ça ce matin !

Le 03/04/2015 à 09:57

Comme promis voilà le fichier..

(Compressé parce que trop gros)

22test-bl.zip (277.14 Ko)
Le 04/04/2015 à 11:57

bonjour

ci joint une proposition

le gros problème dans ton fichier c'est qu'il y a plein de cellules fusionnées, et c'est cela qui pose problème.....

c'est une proposition qui marche mais qui peut certainement être améliorée...

bon WE de Pâques

Fred

35test-bl.zip (274.99 Ko)
Le 07/04/2015 à 12:52

Super, vraiment, ça marche niquel !

Merci beaucoup Fred pour toute ton aide, bonne continuation et bonne journée !

Rechercher des sujets similaires à "enregistrement plage nouveau fichier"