Enregistrer chaque feuille d'un classeur comme nouveau classeur

Bonjour à Toutes et Tous

Je cherche une macro qui me permettrai d'enregistrer chaque onglet dans un nouveau classeur, et que ce dit classeur porte le nom de l'onglet en question.

Mille Merci pour votre aide

Bonjour a tous,

Voici un code qui devrait résoudre ta problématique ;)

Sub ExporterOngletsEnClasseur()
    Dim ws As Worksheet
    Dim wbNouveau As Workbook
    Dim chemin As String

    ' Dossier de sauvegarde (à adapter)
    chemin = ThisWorkbook.Path & "\"

    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        Set wbNouveau = ActiveWorkbook
        wbNouveau.SaveAs Filename:=chemin & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        wbNouveau.Close SaveChanges:=False
    Next ws
End Sub

PS: veux tu ignorer la première page ?

Bonjour Paul,

Merci pour ta réponse rapide et je réponds à ta question. Je souhaite ignorer la première page

J'avais une autre question, saurais tu m'aider pour faire à partir de ces fichiers un envoi de mail avec un mail type

Bonsoir,

Peux tu clarifier, tu veux envoyer un mail avec du VBA? Ou tu veux créer du contenu/text a envoyer qui sera envoyé par un logiciel/outil tierce ?

Paul

Le code pour ignorer la première page, dis moi si tu préfère pouvoir renseigner le voir les noms de feuilles a retirer.

Sub ExporterOngletsEnClasseur()

Dim ws As Worksheet

Dim wbNouveau As Workbook

Dim chemin As String

' Dossier de sauvegarde (à adapter)

chemin = ThisWorkbook.Path & "\"

For Each ws In ThisWorkbook.Worksheets

If ws.Index <> 1 Then ' Ignore la première feuille

ws.Copy

Set wbNouveau = ActiveWorkbook

wbNouveau.SaveAs Filename:=chemin & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook

wbNouveau.Close SaveChanges:=False

End If

Next ws

End Sub

Bonjour Paul,

Pour répondre à tes deux questions, voici des réponses qui je l'espère pour éclaircir mes demandes.

Je ne souhaites pas spécialement pouvoir avoir une action quelconque sur les les noms de feuilles a retirer.

Pour l'envoi de mail, je souhaites effectuer les taches suivantes

Depuis le tableau que tu as, mon but est de pouvoir via outlook.fr ou pas, envoyer un mail communs à l'ensemble des contacts présent sur le fichier Excel.

Je te joins ci-dessous une vue du mail à envoyer.

Objet du mail : Optimiser les coûts et les approches dans les techniques spéciales du bâtiment avec votre partenaire Projet-Tech-Elec

Bonjour,

On peut le faire en VBA mais tu vas à coup sûr finir dans les spam.

Tu devrais utiliser lemlist ou une autre agence spécialisée dans l'emailing.

Si jamais tu veux quand même tester gratuitement par VBA fais le sur une centaine de prospects. Pense à modifier les premières paramètres en haut du code.

Option Explicit

'==== PARAMÈTRES À ADAPTER =====
Private Const EMAIL_COL As String = "E"   ' Colonne des emails
Private Const START_ROW As Long = 1       ' Première ligne
Private Const SEND_NOW As Boolean = False ' True = .Send, False = .Display
Private Const SUBJECT_TXT As String = "Proposition de sous-traitance en ingénierie électrique"
' URL du site (laisser vide si non souhaité)
Private Const WEBSITE_URL As String = "https://votre-site-exemple.fr"
' Colonne contenant le nom à insérer (0 = désactivé). Exemple: "F" si vous avez les noms en F.
Private Const NAME_COL As String = ""     ' Exemple: "F" ou laisser vide
' Pièce jointe optionnelle (laisser vide si aucune)
Private Const ATTACH_PATH As String = ""  ' Exemple: "C:\Docs\portfolio.pdf"
'================================

Public Sub Envoyer_Mails_Identiques()
    Dim olApp As Object, olMail As Object
    Dim ws As Worksheet, lastRow As Long, r As Long
    Dim addr As String, nomPerso As String
    Dim bodyHtml As String
    Dim dict As Object

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, EMAIL_COL).End(xlUp).Row
    If lastRow < START_ROW Then
        MsgBox "Aucune adresse trouvée en colonne " & EMAIL_COL & ".", vbExclamation
        Exit Sub
    End If

    Set olApp = CreateObject("Outlook.Application")
    Set dict = CreateObject("Scripting.Dictionary") ' éviter les doublons

    For r = START_ROW To lastRow
        addr = Trim(CStr(ws.Cells(r, EMAIL_COL).Value))
        If addr <> "" Then
            If Not dict.Exists(LCase$(addr)) And IsValidEmail(addr) Then
                dict.Add LCase$(addr), True

                nomPerso = ""
                If Len(NAME_COL) > 0 Then
                    nomPerso = Trim(CStr(ws.Cells(r, ColLetterToNumber(NAME_COL)).Value))
                End If

                bodyHtml = BuildBodyHtml(nomPerso)

                Set olMail = olApp.CreateItem(0)
                With olMail
                    .To = addr
                    .Subject = SUBJECT_TXT
                    .HTMLBody = bodyHtml
                    If Len(ATTACH_PATH) > 0 Then
                        If Dir$(ATTACH_PATH) <> "" Then .Attachments.Add ATTACH_PATH
                    End If
                    If SEND_NOW Then .Send Else .Display
                End With
            End If
        End If
    Next r

    MsgBox "Traitement terminé. Emails uniques valides: " & dict.Count, vbInformation
End Sub

Private Function BuildBodyHtml(ByVal nomPerso As String) As String
    Dim salutation As String
    Dim siteBloc As String

    ' Salutation: si un nom est fourni, l'insérer après "Madame, Monsieur"
    If nomPerso <> "" Then
        salutation = "Madame, Monsieur " & EncodeHtml(nomPerso) & ","
    Else
        salutation = "Madame, Monsieur,"
    End If

    If Len(WEBSITE_URL) > 0 Then
        siteBloc = "<p>Pour une vue complète de mes prestations, références et outils (Caneco BT, Autocad, Dialux.Evo, etc.), " & _
                   "veuillez consulter mon site : <a href=""" & EncodeHtml(WEBSITE_URL) & """ target=""_blank"">" & EncodeHtml(WEBSITE_URL) & "</a></p>"
    Else
        siteBloc = ""
    End If

    BuildBodyHtml = _
        "<html><body style=""font-family:Calibri,Arial,Helvetica,sans-serif;font-size:11pt;"">" & _
        "<p>" & salutation & "</p>" & _
        "<p>Projet Tec Elec se permet de vous contacter en tant qu’autoentrepreneur en ingénierie et conception de projets électriques, " & _
        "spécialisé dans les domaines tertiaires et industriels : création de plans, schémas unifilaires, calculs de dimensionnement, " & _
        "plans d'implantation HT/BT, études photovoltaïques, etc.</p>" & _
        "<p>Dans un contexte de forte charge de travail ou de besoins en expertise pointue, je propose mes services en sous-traitance, " & _
        "offrant la flexibilité d’un indépendant avec la rigueur d’un ingénieur expérimenté.</p>" & _
        siteBloc & _
        "<p>Je peux étudier vos prochains besoins et proposer une offre de prix compétitive pour toute étude ou mission de conception. " & _
        "Vous pouvez m’adresser les détails d’un projet en cours ou à venir.</p>" & _
        "<p>Dans l’attente de vous lire, veuillez agréer l’expression de ma considération distinguée.</p>" & _
        "<p>Cordialement,<br>" & _
        "Projet-Tech-Elec<br>" & _
        "Christophe Grojean</p>" & _
        "</body></html>"
End Function

Private Function IsValidEmail(ByVal s As String) As Boolean
    ' Validation simple via RegExp
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Pattern = "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}$"
        .IgnoreCase = True
        .Global = False
    End With
    IsValidEmail = re.Test(Trim$(s))
End Function

Private Function ColLetterToNumber(ByVal colLetter As String) As Long
    Dim i As Long, result As Long
    colLetter = UCase$(Trim$(colLetter))
    For i = 1 To Len(colLetter)
        result = result * 26 + (Asc(Mid$(colLetter, i, 1)) - 64)
    Next i
    ColLetterToNumber = result
End Function

Private Function EncodeHtml(ByVal s As String) As String
    s = Replace(s, "&", "&")
    s = Replace(s, "<", "<")
    s = Replace(s, ">", ">")
    s = Replace(s, """", """)
    s = Replace(s, "'", "'")
    EncodeHtml = s
End Function

IMMENSE MERCI PAUL

Cela fonctionne à merveille

Avec grand plaisir, content d'avoir pu te rendre service et bon prospection 😎

Paul

N'hésite pas à mettre en résolu 😉