XL 2016 Exporter une plage de cellules au format .xlsx

[KTM]

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

 

[mapomme]

Bonjour @KTM 🙂,

Un essai dans le fichier joint:

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

 

[KTM]

Bonjour @KTM 🙂,

Un essai dans le fichier joint:

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]

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".

 

[job75]

Bonjour KTM, mapomme,

Ici seules les cellules visibles du UsedRange sont copiées et collées dans le nouveau classeur :

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+

 

[mapomme]

Bonjour job75 🙂

 

[KTM]

Bonjour KTM, mapomme,

Ici seules les cellules visibles du UsedRange sont copiées et collées dans le nouveau classeur :

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]

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!!