XL 2016 Exporter une plage de cellules au format .xlsx

KTM

XLDnaute Impliqué
Bonjour Forum
Je travaille sur une base de donnée et souvent j'ai besoin de copier cette base dans un nouveau classeur pour d'autres usages.
j'ai bricoler la macro si dessous mais apparemment ç'est pas parfait.
Pouvez vous m'apporter une aide?

Sub EXPORT()
Dim chemin, NomFichier As String, p As Range
Dim f As Worksheet
Set f = Sheets("RDV")
Set p = f.Range("A1:G" & f.UsedRange.Rows.Count)
chemin = ThisWorkbook.Path & "\Dossier_RDV\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
NomFichier = "RDV" & ".xlsx"

p.SaveAs Filename:= _
chemin & NomFichier, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End Sub
 

Pièces jointes

  • Exemple.xlsm
    31.6 KB · Affichages: 10

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @KTM :),

Un essai dans le fichier joint:
VB:
Sub EXPORT()
Dim chemin
  Sheets("RDV").Copy
  With ActiveWorkbook.Worksheets(1)
    .Range(.Cells(1, "h"), .Cells(1, .Columns.Count)).EntireColumn.Delete
    chemin = ThisWorkbook.Path & "\Dossier_RDV\"
    If Dir(chemin & "NUL") = "" Then MkDir chemin
    On Error GoTo Err001
    .Parent.SaveAs Filename:=chemin & "RDV.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  End With
  Exit Sub
Err001:
  MsgBox "Le fichier n'a pas été sauvegardé !", vbCritical
End Sub
 

Pièces jointes

  • KTM- export- v1.xlsm
    34.7 KB · Affichages: 9

KTM

XLDnaute Impliqué
Bonjour @KTM :),

Un essai dans le fichier joint:
VB:
Sub EXPORT()
Dim chemin
  Sheets("RDV").Copy
  With ActiveWorkbook.Worksheets(1)
    .Range(.Cells(1, "h"), .Cells(1, .Columns.Count)).EntireColumn.Delete
    chemin = ThisWorkbook.Path & "\Dossier_RDV\"
    If Dir(chemin & "NUL") = "" Then MkDir chemin
    On Error GoTo Err001
    .Parent.SaveAs Filename:=chemin & "RDV.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  End With
  Exit Sub
Err001:
  MsgBox "Le fichier n'a pas été sauvegardé !", vbCritical
End Sub
Merci infiniment
Pour ne pas paraitre insatiable j'aimerais vous demander comment l'adapter si on devais copier juste le résultat d'un filtre. Par exemple le sexe F ou M
Encore merci pour votre précieuse aide.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

Voir l'essai joint...

J'ai ajouté une fonction qui ne garde que les éléments désirés : Sub NeGarderQue(xFeuil, xcolonne, ParamArray xValeurs())
  • xFeuil est la feuille sur laquelle on travaille
  • xcolonne est la colonne pour laquelle on ne veut garder que certaines valeurs
  • xValeurs est la liste des valeurs à conserver séparées par des virgules
  • ex : Ne garder que les protocoles TDF :NeGarderQue ActiveWorkbook.Worksheets(1), 2, "TDF/3TC/DTG","TDF/3TC/EFV","TDF/3TC/LPV/r"
Si xValeurs est omis, alors on conserve toutes les lignes (pas de filtrage).

C'est adapté à votre cas -> Les données sont sur les colonnes 1 à 7 (A à G) et les en-tête sont sur la ligne 1.

Un appel à cette procédure est faite dans la procédure d'exportation.

Pour l’exemple, on ne garde que les lignes dont la colonne 4 est égale à "F".
 

Pièces jointes

  • KTM- export- v2.xlsm
    37.8 KB · Affichages: 10
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour KTM, mapomme,

Ici seules les cellules visibles du UsedRange sont copiées et collées dans le nouveau classeur :
VB:
Sub EXPORT()
Dim chemin$, f$
chemin = ThisWorkbook.Path & "\Dossier_RDV\"
f = "RDV"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
ThisWorkbook.Sheets(f).UsedRange.Copy Workbooks.Add(xlWBATWorksheet).Sheets(1).[A1]
With ActiveWorkbook
    .Sheets(1).Name = f
    .Sheets(1).Columns.AutoFit 'ajustement largeurs
    .SaveAs chemin & f, 51 'format .xlsx
    .Close
End With
End Sub
A+
 

KTM

XLDnaute Impliqué
Bonjour KTM, mapomme,

Ici seules les cellules visibles du UsedRange sont copiées et collées dans le nouveau classeur :
VB:
Sub EXPORT()
Dim chemin$, f$
chemin = ThisWorkbook.Path & "\Dossier_RDV\"
f = "RDV"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
ThisWorkbook.Sheets(f).UsedRange.Copy Workbooks.Add(xlWBATWorksheet).Sheets(1).[A1]
With ActiveWorkbook
    .Sheets(1).Name = f
    .Sheets(1).Columns.AutoFit 'ajustement largeurs
    .SaveAs chemin & f, 51 'format .xlsx
    .Close
End With
End Sub
A+
Merci Job75
Tres gentil de votre part
 

KTM

XLDnaute Impliqué
Re,

Voir l'essai joint...

J'ai ajouté une fonction qui ne garde que les éléments désirés : Sub NeGarderQue(xFeuil, xcolonne, ParamArray xValeurs())
  • xFeuil est la feuille sur laquelle on travaille
  • xcolonne est la colonne pour laquelle on ne veut garder que certaines valeurs
  • xValeurs est la liste des valeurs à conserver séparées par des virgules
  • ex : Ne garder que les protocoles TDF :NeGarderQue ActiveWorkbook.Worksheets(1), 2, "TDF/3TC/DTG","TDF/3TC/EFV","TDF/3TC/LPV/r"
Si xValeurs est omis, alors on conserve toutes les lignes (pas de filtrage).

C'est adapté à votre cas -> Les données sont sur les colonnes 1 à 7 (A à G) et les en-tête sont sur la ligne 1.

Un appel à cette procédure est faite dans la procédure d'exportation.

Pour l’exemple, on ne garde que les lignes dont la colonne 4 est égale à "F".
Super!!
 

Discussions similaires

Réponses
0
Affichages
662