XL 2016 Macro Vb Export

[enzo_s]

Bonjour à tous,

je reviens avec mes questions ;-)

Je suis en train de crée un UserForm comme ci-dessous.

L’idée est que, je dois exporter les divers onglet avec des extensions différente.

Exemple :

Onglet 1 -> PDF
Onglet 2 -> TXT
Onglet 3 -> TXt
Onglet 4 -> TXT

J'ai récupérer une partie du code que j'ai essayé d'adapter. Le premier fonctionne bien en PDF maintenant je bock sur la suite pour faire mes onglet 2 3 et 4

Merci de l'aide

A++

Private Sub CheckBox1_Click()

End Sub

Private Sub CheckBox2_Click()

End Sub

Private Sub CommandButton1_Click()

    Dim NomsFeuilles() As Variant
    Dim i As Integer, idx As Integer
    Dim prefixName As String
    prefixName = Range("A1").Value
    ChangerRepertoire
    For i = 1 To 1
        If Me.Controls("CheckBox" & i) Then
            idx = idx + 1
            ReDim Preserve NomsFeuilles(1 To idx)
            NomsFeuilles(idx) = "Onglet " & i
        End If
    Next

    If idx > 0 Then
Application.DisplayAlerts = False 'on évite les alertes
'Sheets("Onglet 1").Visible = True
With Sheets("Onglet 1") 'on copie la feuille
    .Copy
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=repertoire & prefixName & "_Wizard.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
ActiveWindow.Close 'on ferme
'Sheets("Onglet 1").Visible = False
    End If
End Sub

Sub ChangerRepertoire()
Set NewRep = Application.FileDialog(msoFileDialogFolderPicker)
NewRep.Show
If NewRep.SelectedItems.Count > 0 Then
    repertoire = NewRep.SelectedItems(1) & "\"
    ChDir repertoire
Else
   MsgBox "Aucun Répertoire Sélectionné"
End If
End Sub

Private Sub UserForm_Click()

End Sub

 

[job75]

Bonjour enzo_s,

C'est un problème simple, pas besoin d'UserForm, voyez le fichier joint et cette macro :

Sub Exporter()
Dim chemin$, s As Shape, x$
chemin = ThisWorkbook.Path & "\Export\" 'dossier à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier txt existe déjà
For Each s In ActiveSheet.Shapes
    x = s.TextFrame.Characters.Text
    If x Like "Onglet*" Then
        If s.ControlFormat.Value = xlOn Then
            With Sheets(Left(x, InStr(x, "-") - 2))
                .Visible = xlSheetVisible
                If Right(x, 3) = "PDF" Then
                    .ExportAsFixedFormat xlTypePDF, chemin & x & Format(Now, " yyyymmdd")
                Else
                    .Copy
                    ActiveWorkbook.SaveAs chemin & x & Format(Now, " yyyymmdd"), xlText
                    ActiveWorkbook.Close
                End If
            End With
        End If
    End If
Next
End Sub

A+

 

[enzo_s]

Merci Job75 de ton aide c'est vraiment plus simple comme tu le propose

J'essaye de l'adapter sur mon fichier qui lui à des onglets qui ce nome : J'ai aussi changé le nom des Check Case en : mais je pense qu'il faudrait chnager "If x Like "Onglet*" Then" avec autre chose


SSO Config
Wizard
Global Config
Etc

Mais ça ne fonctionne pas


Sinon pour choisir le répertoire j'ai aussi essayer d'ajouter cette partie du code mais sans succès aussi. Il faudrait que j'ai le choix du répertoire.

Sub ChangerRepertoire()
Set NewRep = Application.FileDialog(msoFileDialogFolderPicker)
NewRep.Show
If NewRep.SelectedItems.Count > 0 Then
    repertoire = NewRep.SelectedItems(1) & "\"
    ChDir repertoire
Else
   MsgBox "Aucun Répertoire Sélectionné"
End If
End Sub

 

[job75]

Quand on veut adapter une macro il faut se donner un peu de mal, voyez ce fichier (2) :

Sub Exporter()
Dim chemin$, s As Shape, x$
ChDir ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "DOSSIER D'ENREGISTREMENT"
    If Not .Show Then Exit Sub
    chemin = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier txt existe déjà
For Each s In ActiveSheet.Shapes
    x = s.TextFrame.Characters.Text
    If x <> "Exporter" Then
        If s.ControlFormat.Value = xlOn Then
            With Sheets(Left(x, InStr(x, "-") - 2))
                .Visible = xlSheetVisible
                If Right(x, 3) = "PDF" Then
                    .ExportAsFixedFormat xlTypePDF, chemin & x & Format(Now, " yyyymmdd")
                Else
                    .Copy
                    ActiveWorkbook.SaveAs chemin & x & Format(Now, " yyyymmdd"), xlText
                    ActiveWorkbook.Close
                End If
            End With
        End If
    End If
Next
End Sub

 

[enzo_s]

Merci Job75,

Enfaîte, je suis novice en macro mais j'essaye d’acquérir cette façon de pensée qui n'est pas facile pour le moment ;-)

En tout cas merci pour la connaissance apporter dans ton code mais c'est vrai que c'est pas facile mais ça finira par rentré.

Je me permets de te poser un question, la macro dans ton classeur fonctionne bien mais quand je le met chez moi il y a une erreur 438.

J'ai chercher sur le net et le forum, certain dissent de supprimer le fichier qui ce trouve dans C:\Users\xxx\AppData\Local\Temp\VBE

mais ça ne change rien. Ce qui est étrange c'est que ça fonctionne dans ton fichier. La macro met le debug sur la ligne "x = s.TextFrame.Characters.Text"

Encore merci de ton aide

 

[job75]

Si dans la feuille active il y a d'autres Shapes que celles de mon fichier il peut y avoir un bug en effet.

Il faudrait voir votre fichier pour adapter le code.

 

[enzo_s]

Re salut Job75 !

Je joins le fichier de test, les check case sont sur l'onglet Export.

J'ai ajouter les commentaires mais c'est pas gagné

 

[job75]

Il n'y a aucun bug chez moi sur votre dernier fichier !

Cela dit dans ce fichier (3) j'utilise la collection CheckBoxes au lieu de la collection Shapes, c'est nettement mieux :

Sub Exporter()
Dim chemin$, cb As Object, x$
ChDir ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "DOSSIER D'ENREGISTREMENT"
    If Not .Show Then Exit Sub
    chemin = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier txt existe déjà
For Each cb In ActiveSheet.CheckBoxes
    If cb.Value = xlOn Then
        x = cb.Text
        With Sheets(Left(x, InStr(x, "-") - 2))
            .Visible = xlSheetVisible
            If Right(x, 3) = "PDF" Then
                .ExportAsFixedFormat xlTypePDF, chemin & x & Format(Now, " yyyymmdd")
            Else
                .Copy
                ActiveWorkbook.SaveAs chemin & x & Format(Now, " yyyymmdd"), xlText
                ActiveWorkbook.Close
            End If
        End With
    End If
Next
End Sub

 

[enzo_s]

Super ça fonctionne avec CheckBox !

J'avance petit à petit sur la macro et merci de l'aide.

Maintenant, j'ai fais une macro "test 6" pour faire l'export en XLSX et j'ai essaye de mettre le code avec le tiens.

Mais je bloc sur "With Sheets(Left(x, InStr(x, "-") - 2))" . J'ai essayé de changer le code à la place de celui que fait le fichier TXT pour faire un test mais ça bloc

'  
            Else
                .Copy
                ActiveWorkbook.SaveAs chemin & x & Format(Now, " yyyymmdd") & ".xlsx"
                ActiveWorkbook.Close

Sub Tes6t()
Dim newWbk As Workbook, feuilCal As Worksheet, pathMesDocuments As String, nomNewClasseur As String
Dim chemin$, cb As Object, x$
ChDir ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Save As"
    If Not .Show Then Exit Sub
    chemin = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier txt existe déjà
    'définir la feuille à copier
   Set feuilCal = ThisWorkbook.Sheets("RITM-Security_Rules")
 
    'créer un nouveau classeur avec une seulle feuille
   Set newWbk = Application.Workbooks.Add(xlWBATWorksheet)
 
    'copier les cellules de la feuille "RITM-Security_Rules"
   feuilCal.Cells.Copy
 
    'coller les valeurs dans le nouveau classeur, puis les formats, puis les largeurs de colonnes
   newWbk.Sheets(1).Range("A1").PasteSpecial xlPasteValues
    newWbk.Sheets(1).Range("A1").PasteSpecial xlPasteFormats
    newWbk.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
    Application.CutCopyMode = False
 
    'récupérer le nom à donner au nouveau classeur
   nomNewClasseur = feuilCal.Range("A57") & " " & feuilCal.Range("B3")
 
    'sauvegarder le classeur et le fermer
 ActiveWorkbook.SaveAs chemin & x & nomNewClasseur & ".xlsx"
 ActiveWorkbook.Close
End Sub

 

[job75]

Avec ce fichier (4) on peut enregistrer au format xlOpenXMLWorkbook (.xlsx) :

ActiveWorkbook.SaveAs chemin & x & Format(Now, " yyyymmdd"), IIf(Right(x, 3) = "TXT", xlText, xlOpenXMLWorkbook)

 

[enzo_s]

Purée je cherche dix fois trop loin 🙄 Merci

Ton fichier fonctionne mais quand je l'ai copié dans le miens qui est en PJ ça fonctionne pas. J'ai erreur sur cette ligne" With Sheets(Left(x, InStr(x, "-") - 2))"

Une dernière question après promis je t’embêtes plus ;-)

Je voulais mettre encore une condition pour fusionner des fichier txt qui sont en rouge ci-dessous. Donc chaque bloc feront un seul fichier.

J'avais repris une macro que tu avais fais il y a quelque temps.

Sub Export()
Dim prefixName As String
Dim fichier As Variant, F As Worksheet, tablo, i&, txt$
prefixName = Range("A1").Value
ChDir ThisWorkbook.Path & "\" 'dossier affiché
fichier = prefixName & " " & Format(Date, "yyyy-mm-dd")
fichier = Application.GetSaveAsFilename(fichier, "Text Files (*.txt), *.txt")
If fichier = False Then Exit Sub
For Each F In Sheets(Array("Step3_Interfaces Creation", "Step4_Global_Configuration", "Step5_RF-Profiles", "Step6_Aps_Grps", "Step_7_Flex-SiteCode_Config", "Step10_Final_Bkp"))
    tablo = F.UsedRange.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        If Not IsError(tablo(i, 1)) Then If tablo(i, 1) <> "!" Then txt = txt & vbCrLf & tablo(i, 1)
Next i, F
Open fichier For Output As #1
Print #1, Mid(txt, 2)
Close #1
End Sub

La macro fonctionne très bien isolée mais je vois pas comment je pourrais l'ajouter sur la tienne

En tout cas encore merci de te lumière parce que chez moi il fait noir 😀

A++