Microsoft 365 copie de données colonne dans des nouveaux onglets

[FCMLE44]

Bonjour

Dans le fichier ci joint je souhaiterais à chaque changement de données de la colonne C de la feuille Base créer un onglet du même nom et copier les données
Ex: j'ai la donnée dupont dans la colonne C de l'onglet base, je crée un onglet du nom de dupont et copie toutes les données de dupont dans la feuille dupont

Voici ce que j'ai écrit, ca fonctionne :

Function exist(Nom)
exist = False
On Error Resume Next
    Set x = Sheets(Nom)
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function
Sub Balaye1()
tablo = Sheets("Base").Range("A1").CurrentRegion
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) + 1 To UBound(tablo, 1)
   x = tablo(n, 1)
   dico(x) = x
Next
a = dico.keys
For n = LBound(a) To UBound(a)
    If Not exist(a(n)) Then
        Sheets.Add.Name = a(n)
        ActiveSheet.Move after:=Sheets(Sheets.Count)
        Sheets("Base").Rows(1).Copy Destination:=ActiveSheet.Range("A1")
    End If
    ind = 0
    ReDim tabres(UBound(tablo, 1), UBound(tablo, 2))
    For m = LBound(tablo, 1) + 1 To UBound(tablo, 1)
       If tablo(m, 1) = a(n) Then
          For p = LBound(tablo, 2) To UBound(tablo, 2)
              tabres(ind, p - 1) = tablo(m, p)
          Next
             ind = ind + 1
       End If
    Next
    Sheets(a(n)).Range("A2").Resize(UBound(tabres, 1), UBound(tabres, 2)) = tabres
Next
End Sub

Et dans un 2e temps, je souhaiterais créer un classeur aves tous les nouveaux onglets créés et les enregistrer dans le répertoire de mon choix

J'ai écris cela mais ca me l'enregistre dans mes documents et je ne sais pas comment je pourrais le modifier pour enregistrer les fichiers dans le répertoire de mon choix

Sub saveOnglet()
Dim ws
Dim newWk As Workbook

    For Each ws In Worksheets
        Set newWk = Workbooks.Add(xlWBATWorksheet)
        ws.Copy newWk.Sheets(1)
        newWk.SaveAs (ws.Name & ".xls")
        newWk.Close
        Set newWk = Nothing
    Next ws

End Sub

Quelqu'un aurait il une idée ?

Merci

 

[Robert]

Bonjour FCMLE, bonjour le forum

Si le chemin n'est jamais le même essaie le code ci-dessous :

Sub saveOnglet()
Dim ws
Dim newWk As Workbook
Dim ED As FileDialog 'déclare la variable EF (Exporateur de Dossiers)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set ED = Application.FileDialog(msoFileDialogFolderPicker) 'définit ED (permet de sélectionner un dossier)
    ED.AllowMultiSelect = False 'n'autorise la sélection que d'un seul dossier
    ED.Show 'affiche ED
    If ED.SelectedItems.Count > 0 Then CA = ED.SelectedItems(1) 'si un dossier a été sélectionné, définit le chemin d'accès CA
    For Each ws In Worksheets 'boucle sur tous les onglets
        ws.Copy 'copie l'onglet dans un classeur vierge
        Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
        newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
        newWk.Close 'ferme newWk
        Set newWk = Nothing 'vide newWk
    Next ws 'prochain onglet de la boucle
Application.ScreenUpdating = True 'autorise les rafraîchissements d'écran
End Sub

Il te permet de sélectionner au préalable ton dossier. Sinon, si le chemin est toujours le même, ça donnerait :

Sub saveOnglet()
Dim ws
Dim newWk As Workbook
Dim CA As String 'déclare la variable CA (Chemin d'Accès)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
CA = "C:\blablabla\blobloblo" 'définit le chemin d'accès CA (à ajuster à ton cas)
For Each ws In Worksheets 'boucle sur tous les onglets
    ws.Copy 'copie l'onglet dans un classeur vierge
    Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
    newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
    newWk.Close 'ferme newWk
    Set newWk = Nothing 'vide newWk
Next ws 'prochain onglet de la boucle
Application.ScreenUpdating = True 'autorise les rafraîchissements d'écran
End Sub

 

[FCMLE44]

Bonjour FCMLE, bonjour le forum

Si le chemin n'est jamais le même essaie le code ci-dessous :

Sub saveOnglet()
Dim ws
Dim newWk As Workbook
Dim ED As FileDialog 'déclare la variable EF (Exporateur de Dossiers)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set ED = Application.FileDialog(msoFileDialogFolderPicker) 'définit ED (permet de sélectionner un dossier)
    ED.AllowMultiSelect = False 'n'autorise la sélection que d'un seul dossier
    ED.Show 'affiche ED
    If ED.SelectedItems.Count > 0 Then CA = ED.SelectedItems(1) 'si un dossier a été sélectionné, définit le chemin d'accès CA
    For Each ws In Worksheets 'boucle sur tous les onglets
        ws.Copy 'copie l'onglet dans un classeur vierge
        Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
        newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
        newWk.Close 'ferme newWk
        Set newWk = Nothing 'vide newWk
    Next ws 'prochain onglet de la boucle
Application.ScreenUpdating = True 'autorise les rafraîchissements d'écran
End Sub

Il te permet de sélectionner au préalable ton dossier. Sinon, si le chemin est toujours le même, ça donnerait :

Sub saveOnglet()
Dim ws
Dim newWk As Workbook
Dim CA As String 'déclare la variable CA (Chemin d'Accès)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
CA = "C:\blablabla\blobloblo" 'définit le chemin d'accès CA (à ajuster à ton cas)
For Each ws In Worksheets 'boucle sur tous les onglets
    ws.Copy 'copie l'onglet dans un classeur vierge
    Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
    newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
    newWk.Close 'ferme newWk
    Set newWk = Nothing 'vide newWk
Next ws 'prochain onglet de la boucle
Application.ScreenUpdating = True 'autorise les rafraîchissements d'écran
End Sub

Merci Top
Bonne journée

 

[FCMLE44]

Dans ce bout de code, j'aimerais exclure la feuille Base, à part en ajoutant un If je ne vois pas autre chose

For Each ws In Worksheets 'boucle sur tous les onglets

Votre avis ou votre idée ?

 

[Robert]

Re,

À par le If... End If, je ne vois pas non plus :

For Each ws In Worksheets 'boucle sur tous les onglets
    If Not ws.Name = "Base" Then
        ws.Copy 'copie l'onglet dans un classeur vierge
        Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
        newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
        newWk.Close 'ferme newWk
        Set newWk = Nothing 'vide newWk
    End If
Next ws 'prochain onglet de la boucle

 

[FCMLE44]

Re,

À par le If... End If, je ne vois pas non plus :

For Each ws In Worksheets 'boucle sur tous les onglets
    If Not ws.Name = "Base" Then
        ws.Copy 'copie l'onglet dans un classeur vierge
        Set newWk = ActiveWorkbook 'définit le nouveau classeur newWk
        newWk.SaveAs (CA & "\" & ws.Name & ".xls") 'enregistre sous newWk
        newWk.Close 'ferme newWk
        Set newWk = Nothing 'vide newWk
    End If
Next ws 'prochain onglet de la boucle

Merci je vais faire comme ca