Code VBA pour réorganisation d'un fichier Fermé

Question

Bonjour,  



Voila j'ai un fichier excel qui contient des données. Ce fichier est inexploitable en l'état, je voudrais modifier son organisation pour pouvoir bénéficier des données. J'ai commencé à écrire en VBA. 

Voici l'architecture du fichier 




Société Commerciale Type indicateur   représentants   Pharmaciens    Hôpitaux 

127                        Expédition               10                    50                100 
                             Colis                       6                    100                93 
                             Poids                      30                   40                 230 
130                        Expédition               10                    50                100 
                             Colis                       6                    100                93 
                             Poids                      30                   40                 230 

le résultat doit être le suivant 

Société Commerciale   Type de destinataire     Expédition   Colis      Poids   
127                           Représentant                   10          6          30 
127                           pHARMACIENS                   50        100         93 
127                           HOPITAUX                      100            93       230 


Voici le code que j'ai commencé à écrire 

Sub RécupérerLignesDétail() 

Set sht = Sheets("Base Donnée") 
Application.Calculation = xlCalculationManual 
'étape 1 : effacer le contenu de la base Base Donnée 
sht.Range("A4:L65000").ClearContents 
'étape 2 : repérer la dernière ligne remplie d'après la collonne K 
    n = Range("K65000").End(xlUp).Row 
'étape 3 : balayage de la liste et écriture dans Base Donnée 
    Numbd = 4 'N° de la ligne Base Donnée ou écrire l'enregistrement 
    For I = 1 To n 
        If Cells(I, 1) <> "" Then 

         
        'étape 3-1 : récupération des informations 
        SOCIETE = Cells(I, 1) 
        Grossistes = Cells(I, 3) 
        Représentants = Cells(I, 4) 
        Pharmaciens = Cells(I, 5) 
        Hôpitaux = Cells(I, 6) 
        Prestataires = Cells(I, 7) 
        Dentistes = Cells(I, 8) 
        International = Cells(I, 9) 
        Divers = Cells(I, 10) 
         
        'étape 3-2 : écriture des informations dans la Base Donnée 
        sht.Cells(Numbd, 2) = Grossistes 
        sht.Cells(Numbd, 3) = Représentants 
        sht.Cells(Numbd, 4) = Pharmaciens 
        sht.Cells(Numbd, 1) = SOCIETE 
        sht.Cells(Numbd, 5) = Hôpitaux 
        sht.Cells(Numbd, 6) = Prestataires 
        sht.Cells(Numbd, 7) = Dentistes 
        sht.Cells(Numbd, 8) = International 
        sht.Cells(Numbd, 9) = Divers 
        Numbd = Numbd + 1 'Incrément du n° de ligne de la Base Donnée 
    End If 
     
Next I 

sht.Range("A2") = "Liste récupérée le " & Date & " a " & Time 
Application.Calculation = xlCalculationAutomatic 

End Sub

michel_m · Answer

bonjour,

mets en pièce jointe un bout de ton classeur sans données confidentielles (j'ai rien compris à la disposition actuelle et demandée)
si tu ne connais pas:
utilises cijoint.fr
et colles le lien proposé dans ton message
si tu as XL2007 mettre un classeur au format 97-2003

kremelin · Answer

Désolé je n'ai pas été très clair, j'avais oublié de te mettre le résultat que je souhaite. je t'ai mis le résultat sur la feuille base de donnée le deuxième Tableau. le 1 er étant le résultat de mon code Vba. 

http://www.cijoint.fr/cjlink.php?file=cj201010/cijilrF8VL.xls

J'espère être plus clair cette fois ci


merci

kremelin · Answer

ok

merci beaucoup..

@+

michel_m · Answer

re, 

proposition: 
http://www.cijoint.fr/cjlink.php?file=cj201010/cijDePUBOp.xls 

ze macro VBA: 
Option Explicit 

Sub recuperer_detail_lignes() 
Dim Derlig As Long, Lig As Long, col As Byte 
Dim tablo 
Dim cptr As Long, cptr_l As Byte, destinater As Range

ReDim tablo(7, 0) 

With Sheets("sheet1") 
    Derlig = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row 

    For Lig = 2 To Derlig Step 6 
    'test = .Cells(Lig, 1) 
            For col = 3 To 10 
             set destinater = Range(.Cells(Lig, col), .Cells(Lig + 5, col)) 
                If Application.Sum(destinater) > 0 Then 
                    ReDim Preserve tablo(7, cptr) 
                    tablo(0, cptr) = .Cells(Lig, 1) 
                    tablo(1, cptr) = .Cells(1, col) 
                    For cptr_l = 2 To 7 
                        tablo(cptr_l, cptr) = .Cells(Lig + cptr_l - 2, col) 
                    Next 
                    cptr = cptr + 1 
                 End If 
            Next 
    Next 
End With 

Application.ScreenUpdating = False 
With Sheets("base donnée") 
    .Range("A2") = "liste récupérée le " & Format(Date, "dd/mm/yy") & " à " & Format(Time, "hh:mm:ss") 
    .Range("A5:H10000").Clear 
    With .Range("A5").Resize(cptr, 8) 
        .Value = Application.Transpose(tablo) 
        .Borders.Weight = xlThin 
    End With

Tu dis... 
Michel