XL 2019 EXCEL 2019 - VBA Export tableau millier de lignes dans classeur chaque 100 lignes

[iStarsS]

Bonjour à tous,

Je casse les dents sur une macro que je voudrais faire et j'en viens donc a demander l'aide d'un pro du VBA.

J'ai un classeur dans lequel je fait plein de post-traitements (liaisons power query, formules, etc...).
J'obtient à la fin une feuille "RESULTATS" dans laquelle j'ai un objet "Tableau" avec en-tête qui fait des milliers de lignes avec des résultats de formules.
Or pour l'usage attendu de ces traitements (imports de données dans un logiciel), j'ai besoin que mes données soient dans des classeurs distincts avec une seule feuille à chaque fois et 100 lignes maximum + l'en-tête des colonnes.

Je cherche donc avec une macro à exporter mon tableau, en valeurs, dans un nouveau classeur toutes les 100 lignes + l'en-tête de mon tableau

J'ai bidouillé tout un tat de macros, mais je n'arrive pas au résultat attendu.

En remerciant par avance de votre aide.

 

[xUpsilon]

Bonjour,

Sans classeur exemple, ça commence mal, mais voici une idée de structure, à traduire en VBA.

Const nPremLig as Integer = 1
Const sPremCol as String = "A"
Const sDerCol as String = "Z"

nDerLig = Dernière ligne du tableau

Dim oWbk_Source as Excel.Workbook
Dim oWbk_Desti as Excel.Workbook
Set oWbk_Source = ThisWorkbook

For nLig = 0 to Worksheetfunction.RoundUp(nDerLig/100,0)
    Set oWbk_Desti = Nouveau classeur
    Range(sPremCol & nPremLig & ":" & sDerCol & (nLig+1)*100 + 1).Copy
    Nouveau classeur.Sheet1.PasteSpecial xlPasteValues
    Save & Close nouveau classeur
Next nLig

A ta place, je chercherais surtout comment éviter cette logique de 100 lignes par classeur, parce que pour plusieurs milliers de lignes ça va faire plusieurs dizaines de classeur, ce qui est super lourd.

Bonne journée,

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @iStarsS
Une macro qui fonctionne pour une feuille contenant 1 seul tableau structuré :

Sub HacherMenu()
'Nb de lignes de données des fichier cibles
     Const taille As Integer = 100
'Nom du Sous-répertoire cible
     Const Cible$ = "\Extraits"
'Préfixe du nom des fichiers cibles
     Const NomFich$ = "Extrait N°"
    
     Dim WSh As Worksheet, LO As ListObject, Ligne As Range, N_Wsh As Worksheet
     Dim Entête, Tb, NbBoucles As Long, i As Long

'La feuille contenant l'objet tableau (tableau structuré)
     Set WSh = Feuil1
'Le tableau structuré source
     Set LO = WSh.ListObjects(1)
'La première ligne de données
     Set Ligne = WSh.Evaluate(LO.Name).Rows(1)
'l'Entête du tableau
     Entête = LO.HeaderRowRange.Value
'Nombre de colonnes du tableau
     NbCol = UBound(Entête, 2)
'Calcul du nombre de boucles (arrondi à l'entier supérieur)
     Nb = WSh.Evaluate(LO.Name).Rows.Count / taille
     NbBoucles = Int(Nb) + IIf(Nb > Int(Nb), 1, 0)
'Répertoire contenant Ce fichier
     Chemin = ThisWorkbook.Path
'Nettoyage des anciens résultats
     Application.ScreenUpdating = False
     If Dir(Chemin & Cible, vbDirectory) <> "" Then
          On Error Resume Next
          Kill Chemin & Cible & "\*.*"
          On Error GoTo 0
     Else
          MkDir Chemin & Cible
     End If
     For i = 0 To NbBoucles - 1
          Tb = Ligne.Offset(i * 100).Resize(100).Value
          Set N_Wsh = Workbooks.Add.Worksheets(1)
          N_Wsh.Rows(1).Resize(1, NbCol).Value = Entête
          N_Wsh.Rows(2).Resize(100, NbCol).Value = Tb
          N_Wsh.Parent.SaveAs Filename:=Chemin & Cible & "\" & NomFich & Format(i + 1, "000000") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
          N_Wsh.Parent.Close Savechanges:=False
     Next
     Application.ScreenUpdating = True
End Sub

Voir fichier en PJ
Amicalement
Alain
PS N'oublie pas , si une réponse répond à tes attente, marque la comme solution...

 

[iStarsS]

Bonjour,

Sans classeur exemple, ça commence mal, mais voici une idée de structure, à traduire en VBA.

Const nPremLig as Integer = 1
Const sPremCol as String = "A"
Const sDerCol as String = "Z"

nDerLig = Dernière ligne du tableau

Dim oWbk_Source as Excel.Workbook
Dim oWbk_Desti as Excel.Workbook
Set oWbk_Source = ThisWorkbook

For nLig = 0 to Worksheetfunction.RoundUp(nDerLig/100,0)
    Set oWbk_Desti = Nouveau classeur
    Range(sPremCol & nPremLig & ":" & sDerCol & (nLig+1)*100 + 1).Copy
    Nouveau classeur.Sheet1.PasteSpecial xlPasteValues
    Save & Close nouveau classeur
Next nLig

A ta place, je chercherais surtout comment éviter cette logique de 100 lignes par classeur, parce que pour plusieurs milliers de lignes ça va faire plusieurs dizaines de classeur, ce qui est super lourd.

Bonne journée,

Un grand merci xUpsilon,

J'ai réussi à faire ce que je voulais en basant sur ton code.

Tu m'as bien aidé.