Const ChaineCherche$ = "."
Const NomF$ = "EXTRACTION DE BASE" ' à adapter
Sub Princ()
Dim Plage As Range, F As Worksheet
Dim T
Dim I&, Ligne&
Dim C As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'si qques formules
Set F = Sheets(NomF)
T = Array("R1", "R2", "R3", "R4", "R5", "R6", "R7", "R8") ' à adapter on peut aussi recuperer un plage de cellule
With F
.Columns(1).Insert 'on insere 1 colonne
Set Plage = .[A1].CurrentRegion ' à adapter
End With
Filtre F, Plage.Cells(1, 2), ChaineCherche 'on filtre sur la 2émé colonne
With Plage
For Each C In .Columns(1).SpecialCells(xlCellTypeVisible)
Ligne = EnleverCar(C.Address) 'on recupere le numero de ligne
If Ligne > 1 Then
Set Plage = .Resize(Ligne, 3) 'on travaille sur 3 colonnes
On Error Resume Next
F.AutoFilterMode = False 'on ote l'autofiltre afin de remplir les cellules de la 1ere colonne
Range(.Cells(Ligne, 1), .Cells(Ligne, 1).End(xlUp)(2)) = T(I)
If Err <> 0 Then MsgBox "le tableau ne contient pas assez d'éléments": Exit For
I = I + 1
'Cas des dernieres cellules où le point n'apparait pas, à effacer si le . apparait
If I = UBound(T) Then Range(.Cells(Ligne + 1, 1), .Cells(.Cells(Ligne, 2).End(xlDown).Row, 1)) = T(I)
End If
Next C
End With
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Filtre(F As Worksheet, C As Range, Critere)
With F
On Error Resume Next
.AutoFilterMode = Not .AutoFilterMode
On Error GoTo 0
C.AutoFilter 1, Critere
End With
End Sub
Function EnleverCar(C$, Optional I&) 'Zon, on garde que les chifrss
For I = 1 To Len(C)
EnleverCar = EnleverCar & IIf(Asc(Mid(C, I, 1)) < 44 Or Asc(Mid(C, I, 1)) > 58, "", Mid(C, I, 1))
Next I
End Function