Macro pour remplir une base de données

[ueshiba]

Bonjour à toutes et à tous,

J'ai un gros fichier de type adresse mais dont les données sont sur une seule colonne.
Je voudrais remettre en forme ce fichier pour en faire un listing correctement utilisable.

Mon fichier est très gros (environ 58000 lignes) et j'ai dû le scinder en plusieurs morceaux.

J'ai mis un exemple (fictif) des données telles qu'elles se présentent.

Onglet Source :

Colonne A : les adresses
Colonne B : J'ai mis des "marqueurs" sur les zones qui me semblaient importantes :
- (1 à chaque fois qu'il y a une civilité)
- 2 : A chaque fois qu'il ya un code postal

Onglet Base :

j'ai mis en forme les données telles que je voudrais qu'elles soient après "retranscription"

globalement, il me faudrait un petit code VB qui irait chercher les infos lignes par lignes pour les copier/transposer dans le second onglet. A chaque fois qu'il y aurait un "1" dans la colonne B, cela voudrait dire qu'il faut passer à une seconde ligne pour l'onglet "Base". Et de même chaque fois qu'il y aurait un "2" dans la colonne B, cela voudrait dire qu'il faut passer à la colonne "Code postal" de l'onglet "Base".

Le soucis est que je ne connais strictement rien en VB et que faire cette opération manuellement serait monstrueux en temps.

Quelqu'un peut-il m'aider ?

Merci d'avance.

Cdt,

 

[Theze]

Re : Macro pour remplir une base de données

Bonjour,

Voici une macro qui fait ce que tu demande. Elle aurait été plus simple si tes enregistrements avaient des champs de même longueur. Teste pour voir si ça te convient. Fait le test sur une copie de ton classeur :

Sub RecupBase()

Dim Plage As Range
Dim Cel1 As Range
Dim Cel2 As Range
Dim Tbl(1 To 7) As String
Dim I As Long
Dim J As Integer
Dim K As Integer
Dim L As Long
Dim Adr As String

    With Worksheets("Source")
        
        'en colonne B
        Set Plage = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
        
    End With
    
    Set Cel2 = Plage.Find(1, Plage(1), xlValues, xlWhole)
    
    If Not Cel2 Is Nothing Then
        
        'mémorise la première et son adresse
        Set Cel1 = Cel2
        Adr = Cel2.Address
        
        Do
            
            'recherche la suivante
            Set Cel2 = Plage.FindNext(Cel2)
            
            'si c'est la fin
            If Cel2.Address = Adr Then
                
                'redéfini la dernière cellule
                With Worksheets("Source")
                
                    Set Cel2 = Worksheets("Source").Cells(.Rows.Count, 2).End(xlUp)
                    Adr = Cel2.Address 'mémorise l'adresse pour sortir de la boucle
                    K = Cel2.Row + 1 'incrémente de 1 pour correspondre dans la boucle I
                    
                End With
                
            Else
            
                K = Cel2.Row
                
            End If
            
            'le plus long enregistrement faisant 7 champs
            'on doit retourner systématiquement un tableau à 7 cellules
            For I = 1 To 7
                
                'nombre d'enregistrement
                Select Case 7 - (K - Cel1.Row)
                    
                    'cas où il y a 7 champs
                    Case Is = 0
                    
                        Tbl(I) = Cel1.Offset(I - 1, -1)
                    
                    'cas où il y a 6 champs
                    Case Is = 1
                    
                        If I = 5 Then
                        
                            Tbl(I) = ""
                            
                         Else
                         
                            J = J + 1
                            Tbl(I) = Cel1.Offset(J - 1, -1)
                            
                        End If
                        
                    'cas où il y a 5 champs
                    Case Is = 2
                    
                        If I = 4 Or I = 5 Then
                        
                            Tbl(I) = ""
                            
                         Else
                         
                            J = J + 1
                            Tbl(I) = Cel1.Offset(J - 1, -1)
                            
                        End If
                        
                End Select
             
            Next I
            
            'défini la première ligne vide
            L = Worksheets("Base").Cells(Rows.Count, 1).End(xlUp).Row + 1
            
            J = 0
            
            'colle les valeurs dans la feuille "Base"
            '(la fonction "Transpose" me posant des problèmes ?)
            For I = 1 To 7
            
                J = J + 1
                Worksheets("Base").Cells(L, J) = Tbl(I)
            
            Next I
            
            J = 0
            
            'mémorise la cellule précédente
            Set Cel1 = Cel2
                    
        Loop While Cel2.Address <> Adr
    
    End If

End Sub

Hervé.