XL 2016 Fonction GetSaveAsFilename pour enregistrer une extraction

YANNISE

XLDnaute Nouveau
Bonjour le Forum,

Je voulais extraire les résultats de tableau filtre dans un nouveau classeur Excel avec la fonction GetSaveAsFilename mais j’obtiens aucun résultat ???

Pourriez-vous m'aider SVP, ci-après le code ainsi que le fichier

Sub Save_Doc()

Dim Plage
Dim MonClasseur As Workbook

Application.EnableEvents = False
Application.ScreenUpdating = False


Plage = ListeFichier = Application.GetSaveAsFilename(fileFilter:="Fichiers Excel (*.xls*),*xls*", Title:="Fichier ERP à Importer", ButtonText:="Importer")

If Plage <> False Then
With Feuil1
Set Plage = .Range("B2").CurrentRegion
Set MonClasseur = Workbooks.Add


Plage.SpecialCells(xlCellTypeVisible).Copy ActiveWorkbook.ActiveSheet.Range("A1")
Application.DisplayAlerts = False

Range("A1").Select
ActiveCell.CurrentRegion.EntireColumn.AutoFit




ActiveWorkbook.Close , False

End With
Application.EnableEvents = True

End If

MsgBox "Extraction faite"

End Sub
 

Pièces jointes

  • Fichier1.xlsm
    15.5 KB · Affichages: 2
Solution
Petite corrections faites sur la macro précédente.
Je n'avais pas remarqué que l'on pouvait aller en bug.
Bruno
VB:
Sub Save_Doc()
Dim rep
 Set Plage = Feuil1.Range("B2").CurrentRegion
     Plage.SpecialCells(xlCellTypeVisible).Copy
 Set NewFich = Workbooks.Add
     ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial
     ActiveSheet.Range("A1").CurrentRegion.EntireColumn.AutoFit
rep = Application.GetSaveAsFilename(fileFilter:="Fichiers Excel (*.xls*),*xls*", Title:="Fichier ERP à Importer", ButtonText:="Importer")
If rep = False Then MsgBox "ANNULATION": ActiveWorkbook.Close (False): Exit Sub
  If rep Like ".xls" = False Then rep = rep & ".xls"
   NewFich.SaveAs Filename:=rep
    ActiveWorkbook.Close (False)
MsgBox "Extraction faite"...

youky(BJ)

XLDnaute Barbatruc
Bonjour Yannise,
Voici un code modifié
Bruno
VB:
Sub Save_Doc()
Dim rep
    Set Plage = Feuil1.Range("B2").CurrentRegion
        Plage.SpecialCells(xlCellTypeVisible).Copy
    Set NewFich = Workbooks.Add
        ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial
        ActiveSheet.Range("A1").CurrentRegion.EntireColumn.AutoFit
rep = Application.GetSaveAsFilename(fileFilter:="Fichiers Excel (*.xls*),*xls*", Title:="Fichier ERP à Importer", ButtonText:="Importer")
  If rep = "" Then MsgBox "ANNULATION": Exit Sub
  NewFich.SaveAs Filename:=rep
        ActiveWorkbook.Close , False
MsgBox "Extraction faite"
End Sub
 

youky(BJ)

XLDnaute Barbatruc
Petite corrections faites sur la macro précédente.
Je n'avais pas remarqué que l'on pouvait aller en bug.
Bruno
VB:
Sub Save_Doc()
Dim rep
 Set Plage = Feuil1.Range("B2").CurrentRegion
     Plage.SpecialCells(xlCellTypeVisible).Copy
 Set NewFich = Workbooks.Add
     ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial
     ActiveSheet.Range("A1").CurrentRegion.EntireColumn.AutoFit
rep = Application.GetSaveAsFilename(fileFilter:="Fichiers Excel (*.xls*),*xls*", Title:="Fichier ERP à Importer", ButtonText:="Importer")
If rep = False Then MsgBox "ANNULATION": ActiveWorkbook.Close (False): Exit Sub
  If rep Like ".xls" = False Then rep = rep & ".xls"
   NewFich.SaveAs Filename:=rep
    ActiveWorkbook.Close (False)
MsgBox "Extraction faite"
End Sub
 

Discussions similaires

Réponses
6
Affichages
363

Statistiques des forums

Discussions
302 098
Messages
2 000 387
Membres
214 831
dernier inscrit
cyrilGam