Macro pour créer un fichier récapitulatif

Bonsoir,
Je reçois d'un client central une liste XL de commandes de plusieurs clients dans une feuille.
Il m’envoie un simili tableau croisé avec la liste des produits en ligne, les clients en colonne et leur quantité en intersection.

L'idée, je souhaiterai créer dans un autre fichier XL nommé Récapitulatif, un onglet pour la liste de tous les produits (liste des 121 produits avec somme de toutes les quantités client) et des onglets par Nom client avec la liste de leurs produits et quantités respectives, exemple:

Onglet1=nomClient1 tronqué à10car.

Onglet2=nomClient2 tronqué à10car.

... etc jusqu'au dernier nomClient70

il faudrait ouvrir le fichier Recap, lancer une macro qui ouvre une fenêtre pour aller chercher le fichier source liste des commandes et exécute la répartition, ferme le fichier liste des commandes, et laisse ouvert le fichier Recap.

N'y connaissant rien en Macro VB, je galère et je n'y arrive pas

Un Grand Merci d'avance pour votre aide

Bonjour

Avec ta version je pense que tu n'as pas accès à PowerQuery Donc en effet VBA oblige.

Il faudrait que tu postes un fichier anonymisé (et simplifié) de ce que tu reçois et de la récap que tu souhaites.

voici 2 fichiers exemple...

Sans multiplier les onglets mais en jouant sur les segments

Option Explicit

Sub recap()
Dim fichier, tbl, i, j, wbk As Workbook, ligne

    ' collecte les données du fichier source dans un tableau
    fichier = Application.GetOpenFilename("fichier excel (*.xlsx), *.xlsx", , "Sélection de vos fichiers excel", , False)
    If fichier = False Then Exit Sub
    Set wbk = Workbooks.Open(fichier)
    tbl = Cells(1, 1).CurrentRegion
    wbk.Close

    ' traite le tableau
    If Not ActiveSheet.ListObjects(1).DataBodyRange Is Nothing Then ActiveSheet.ListObjects(1).DataBodyRange.Delete
    ligne = 2
    For i = 2 To UBound(tbl)
        For j = 2 To UBound(tbl, 2)
            If tbl(i, j) <> "" And tbl(i, j) <> 0 Then
                Cells(ligne, 1) = tbl(i, 1)
                Cells(ligne, 2) = tbl(1, j)
                Cells(ligne, 3) = tbl(i, j)
                ligne = ligne + 1
            End If
        Next
    Next

End Sub

fait avec

Merci,

cela fonctionne mais l'idée était d'avoir un onglet par client pour pouvoir ensuite, dans chaque feuille, faire une facture

ok, je vais dispatcher

Option Explicit

Sub recap()
Dim fichier, tbl, i, j, wbk As Workbook, ligne, f As Worksheet, dico As Object, cle

    Set dico = CreateObject("Scripting.Dictionary")

    Application.DisplayAlerts = False
    For Each f In Worksheets
        If f.Name <> "compil" Then f.Delete
    Next
    Application.DisplayAlerts = True

    ' collecte les données du fichier source dans un tableau
    fichier = Application.GetOpenFilename("fichier excel (*.xlsx), *.xlsx", , "Sélection de vos fichiers excel", , False)
    If fichier = False Then Exit Sub
    Set wbk = Workbooks.Open(fichier)
    tbl = Cells(1, 1).CurrentRegion
    wbk.Close

    ' crée les onglets
    For j = 2 To UBound(tbl, 2)
        dico(tbl(1, j)) = ""
    Next
    For Each cle In dico.keys
        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = cle
        End With
        Sheets(cle).Cells(1, 1) = "PRODUIT"
        Sheets(cle).Cells(1, 2) = "QUANTITE"
    Next

    ' traite le tableau
    With Sheets("compil")
    If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
    For i = 2 To UBound(tbl)
        For j = 2 To UBound(tbl, 2)
            If tbl(i, j) <> "" And tbl(i, j) <> 0 Then
                .ListObjects(1).ListRows.Add
                ligne = .ListObjects(1).ListRows.Count
                .ListObjects(1).DataBodyRange.Cells(ligne, 1) = tbl(i, 1)
                .ListObjects(1).DataBodyRange.Cells(ligne, 2) = tbl(1, j)
                .ListObjects(1).DataBodyRange.Cells(ligne, 3) = tbl(i, j)
                ligne = Sheets(tbl(1, j)).Cells(Rows.Count, 1).End(xlUp).Row + 1
                Sheets(tbl(1, j)).Cells(ligne, 1) = tbl(i, 1)
                Sheets(tbl(1, j)).Cells(ligne, 2) = tbl(i, j)
            End If
        Next
    Next
    .Select
    End With

End Sub

ou plus simple sans l'onglet global si inutile

Option Explicit

Sub recap()
Dim fichier, tbl, i, j, wbk As Workbook, ligne, f As Worksheet, dico As Object, cle

    Set dico = CreateObject("Scripting.Dictionary")

    Application.DisplayAlerts = False
    For Each f In Worksheets
        If f.Name <> "compil" Then f.Delete
    Next
    Application.DisplayAlerts = True

    ' collecte les données du fichier source dans un tableau
    fichier = Application.GetOpenFilename("fichier excel (*.xlsx), *.xlsx", , "Sélection de vos fichiers excel", , False)
    If fichier = False Then Exit Sub
    Set wbk = Workbooks.Open(fichier)
    tbl = Cells(1, 1).CurrentRegion
    wbk.Close

    ' crée les onglets
    For j = 2 To UBound(tbl, 2)
        dico(tbl(1, j)) = ""
    Next
    For Each cle In dico.keys
        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = cle
        End With
        Sheets(cle).Cells(1, 1) = "PRODUIT"
        Sheets(cle).Cells(1, 2) = "QUANTITE"
    Next

    ' traite le tableau
    For i = 2 To UBound(tbl)
        For j = 2 To UBound(tbl, 2)
            If tbl(i, j) <> "" And tbl(i, j) <> 0 Then
                ligne = Sheets(tbl(1, j)).Cells(Rows.Count, 1).End(xlUp).Row + 1
                Sheets(tbl(1, j)).Cells(ligne, 1) = tbl(i, 1)
                Sheets(tbl(1, j)).Cells(ligne, 2) = tbl(i, j)
            End If
        Next
    Next

End Sub

Merci c'est exactement ce que je cherchais...

(maintenant je vais essayer de comprendre ton VBA)

Grand merci à toi

Arg, il y a un bug car certains noms client sont trop longs (il y en a avec adresse, email, etc...

J'ai essayé de mettre Left$(cle, 20)

Mais dans le tableau il ne trouve plus les references

Y a t-il un moyen dans le tableau mémoire de tronquer à 20 caractères maxi ?

essaie comme ceci

Option Explicit

Sub recap()
Dim fichier, tbl, i, j, wbk As Workbook, ligne, f As Worksheet, dico As Object, cle

    Set dico = CreateObject("Scripting.Dictionary")

    Application.DisplayAlerts = False
    For Each f In Worksheets
        If f.Name <> "compil" Then f.Delete
    Next
    Application.DisplayAlerts = True

    ' collecte les données du fichier source dans un tableau
    fichier = Application.GetOpenFilename("fichier excel (*.xlsx), *.xlsx", , "Sélection de vos fichiers excel", , False)
    If fichier = False Then Exit Sub
    Set wbk = Workbooks.Open(fichier)
    tbl = Cells(1, 1).CurrentRegion
    wbk.Close

    ' crée les onglets
    For j = 2 To UBound(tbl, 2)
        dico(Left(tbl(1, j), 20)) = ""
    Next
    For Each cle In dico.keys
        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = cle
        End With
        Sheets(cle).Cells(1, 1) = "PRODUIT"
        Sheets(cle).Cells(1, 2) = "QUANTITE"
    Next

    ' traite le tableau
    For i = 2 To UBound(tbl)
        For j = 2 To UBound(tbl, 2)
            If tbl(i, j) <> "" And tbl(i, j) <> 0 Then
                ligne = Sheets(Left(tbl(1, j), 20)).Cells(Rows.Count, 1).End(xlUp).Row + 1
                Sheets(Left(tbl(1, j), 20)).Cells(ligne, 1) = tbl(i, 1)
                Sheets(Left(tbl(1, j), 20)).Cells(ligne, 2) = tbl(i, j)
            End If
        Next
    Next

End Sub

Non ça bug au traitement du tableau :

L'essai que je fais avec ce que tu m'as donné est correct !

Y a t'il des caractères "baroques" dans les adresses qui ne seraient pas acceptés ? as-tu une liste de clients (que tu pourrais me transmettre en mp si besoin)

sinon ajoute des debug.print aux endroits stratégiques pour comprendre ... par exemple pour commencer

    For Each cle In dico.keys
        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = cle
        End With
debug.print cle
        Sheets(cle).Cells(1, 1) = "PRODUIT"
        Sheets(cle).Cells(1, 2) = "QUANTITE"
    Next

Il y a des adresses email avec @ sur certains clients mais plus de caractères spéciaux une fois une fois tronqués à 20.

J'ai juste changé pour pouvoir ouvrir un fichier xls car le fichier d'origine des commandes est un xls et pas un xlsx.

fichier = Application.GetOpenFilename("fichier excel (*.xls*), *.xls*", , "Sélection de vos fichiers excel", , False).

Bug ici :

En PJ le fichier

Cela vient du fichier d'origine ... est-ce que ce tableau n'aurait pas une ligne vierge juste après les en-têtes ? ou ne serait pas calée sur la cellule du haut ?

Je me suis basé sur exemplecommande.xlsx qui commençait tout en haut.

On pourrait remplacer

tbl = Cells(1, 1).CurrentRegion

par

tbl = ActiveSheet.UsedRange

ou

tbl = Cells(rows.count, 1).End(xlup).CurrentRegion

mais la feuille comporte-t-elle d'autres infos ... remets un fichier exemple caractéristique de la réalité.

Oui desolé, le fichier d'origine xls à :

- 3 premières lignes avec quelques infos, à supprimer ou ignorer

- la dernière colonne sans entête pour les totaux par ligne

- une dernière ligne sans nom de produit pour les totaux par colonne.

J'ai recrée le fichier...

Je ne sais pas si cela gène mais j'avais rajouté :

- pour supprimer les 3 premieres lignes

- et fermer le fichier sans sauvegarde

je vais blinder un peu plus la macro demain matin quand il y a absence de titre dans le tableau

y a t'il une ligne vide entre l'en-tête et le tableau ?

Non il n'y a pas de lignes vide entre l'entête et le tableau, on demarre de suite avec les produits: