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

FCMLE44

XLDnaute Impliqué
Supporter XLD
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 :
VB:
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

Code:
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
 

Pièces jointes

  • Classeur1.xlsb
    19.7 KB · Affichages: 7
Dernière édition:

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour FCMLE, bonjour le forum

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

VB:
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 :
Code:
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

XLDnaute Impliqué
Supporter XLD
Bonjour FCMLE, bonjour le forum

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

VB:
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 :
Code:
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
 

Robert

XLDnaute Barbatruc
Repose en paix
Re,

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

VB:
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

XLDnaute Impliqué
Supporter XLD
Re,

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

VB:
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
 

Discussions similaires

Réponses
11
Affichages
238