Import d'adresse depuis doc TXT

Le 28/06/2010 à 20:43

Bonsoir,

Je n'ai pas vraiment trouvé la raison du bug (chez moi, c'est bon)

si bogue encore, localise la ligne du code et dis-moi.

Sub Mail_SansDoublon()
'Macros par Claude Dubois pour "stefart" Excel-Pratique le 28/06/10
Dim Lg&, i&, x&, y&, Sp, T
Dim J As Byte, Cl As Byte, z$, Sep$
        If Cells(3, 1) <> "" Then Exit Sub
    T = Time
        Application.ScreenUpdating = False
        Lg = Range("A65536").End(xlUp).Row
    For i = 2 To Lg
            x = Cells(i, 1).End(xlDown).Row 'première ligne Bloc
            y = Cells(x, 1).End(xlDown).Row 'dernière ligne Bloc
            i = y
        If Len(Cells(y, 1)) > 7 Then 'ne prend pas les EMAIL:vides

            For J = 0 To 4
                z = Left(Cells(y - J, 1), 3)
                    Select Case z
                        Case Is = "EMA": Cl = 9: Sep = " : " 'Cl = colonne
                        Case Is = "WEB": Cl = 8: Sep = " : "
                        Case Is = "FAX": Cl = 7: Sep = " :"
                        Case Is = "GSM": Cl = 6: Sep = " :"
                        Case Is = "TEL": Cl = 5: Sep = " :"
                        Case Else: Exit For
                    End Select
                Sp = Split(Cells(y - J, 1), Sep)
                Cells(x, Cl) = Sp(UBound(Sp))
            Next J

                    Cells(x, 2) = Cells(x, 1)       'nom
                    Cells(x, 3) = Cells(x + 1, 1)   'adresse
                    Cells(x, 4) = Cells(x + 2, 1)   'ville
        End If
    Next i
        Range("i2:i" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        '--- tri par mail ---
    Range("a1:i" & [a65536].End(xlUp).Row).Sort Key1:=Range("i2"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False
        '--- doublons mail ---
    Range("j2") = "=i2<>i3"
    Range("a1:i" & [a65536].End(xlUp).Row + 1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
    "j1:j2"), CopyToRange:=Range("k1"), Unique:=True
                Columns("a:k").Delete
                ActiveWindow.Zoom = 80: Range("a1").Activate
                Columns("a:i").AutoFit
        '--- tri par nom ---
    Range("a1:i" & [a65536].End(xlUp).Row).Sort Key1:=Range("a2"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False
        Application.ScreenUpdating = True
        MsgBox ("temps macro = " & Format(Time - T, "hh:mm:ss"))
End Sub

Amicalement

Claude

29stefart-email-3-2.zip (16.47 Ko)

Le 29/06/2010 à 09:51

Merci Claude pour le doc, Avec ca je devais êtres tranquille.

Je le tester ce midi et te donne le résultat.

Je regarde en même temps si le bug se reproduit encore ou pas !

Stef

-- 29 Juin 2010, 23:43 --

Voici le résultat :

1962 adresses traitées en 1 mn 30

Franchement du travail de Pro.