Besoin d'aide en vba pour copier les cellules sous condition

[impur]

Bonjour à tous,

Voici mon soucis:

J'ai un fichier excel avec plusieurs feuilles

Tableau détaillé, tableau 24, tableau 33, etc etc

Je souhaiterais en VBA:

copier- coller toutes les lignes de la feuille "tableau détaillé" commencant par 24 (colonne A) dans la feuille "tableau 24", de meme avec "tableau 33".

Exemple

Dans "tableau détaillé:

24114 A14 B28
24257 B21 H25 G45
24569 J24
33254 J14
33289
33214
41234
Etc etc

Je souhaiterais copier-coller par exemple toutes les lignes commencant par 24 dans la colonne A de la feuille "tableau détaillé" dans la feuille "tableau 24".

si j'ai ceci dans tableau détaillé:
24114 A14 B28
24257 B21 H25 G45
24569 J24
33254 J14 K12
33289 K11
33214 F68

je dois avoir ceci dans tableau 24:
24114 A14 B28
24257 B21 H25 G45
24569 J24

et ceci dans tableau 33:
33254 J14 K12
33289 K11
33214 F68

Est ce possible d'obtenir une formule en vba pour faire ce travail?

En vba car la feuille "tableau détaillé" est dynamique, donc toute modification effectuée sur celle ci doit se faire aussi dans les autres feuilles.


Cordialement

 

[Cousinhub]

Re : Besoin d'aide en vba pour copier les cellules sous condition

Bonjour,

regarde le fichier joint.

Nota, les modifications ne sont pas automatiques, il te faut appuyer sur le bouton "GO", mais cela prend moins d'un dixième de seconde...

Le code :

Sub eclater()
Dim Sh As Worksheet
Dim Cel As Range
Dim Numeros As Object
Dim It
Dim DerLig As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> "base" Then Sh.Delete
Next Sh
Set Numeros = CreateObject("Scripting.Dictionary")
With Sheets("base")
    DerLig = .[A65000].End(xlUp).Row
    .Range("A1:D" & DerLig).Name = "mabase"
    For Each Cel In .Range("A2:A" & DerLig)
        Numeros(Left(Cel, 2)) = Left(Cel, 2)
    Next Cel
    For Each It In Numeros.Items
        .Range("K2").FormulaR1C1 = "=LEFT(RC[-10],2)*1=" & It
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Tableau " & It
        .Range("mabase").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("K1:K2"), _
            CopyToRange:=Range("A1"), Unique:=False
    Next It
    .[K2].Clear
    .Select
End With
End Sub

Le fichier :

bonne journée