Autres [Discussion Close]

[cp4]

Bonjour🙂,

Le code ci-dessous n'est pas de moi. Je l'ai trouvé sur le net. Mais m’intéresse et voudrais m'en inspirer pour l'adapter à mon besoin.

Option Explicit

Sub Transfert()
    Dim Lg As Long, I As Integer, Cel As Range, MonDico As Object, Tablo(), nb As Integer
    nb = 3
    Application.ScreenUpdating = False
    Set MonDico = CreateObject("Scripting.Dictionary")
    With Sheets("Base")
        Lg = .Range("ad" & Rows.Count).End(xlUp).Row
        For Each Cel In .Range("ad6:ad" & Lg)
            If Cel <> "" Then MonDico(Cel.Value) = Cel.Value
        Next Cel
        Tablo = MonDico.items
        For I = 0 To UBound(Tablo)
            .Range("a5:ad" & Lg).AutoFilter Field:=30, Criteria1:=Tablo(I), VisibleDropDown:=False
            On Error Resume Next
            Sheets(Tablo(I)).Select '***PLANTE ICI
            If Err.Number > 0 Then
                Sheets.Add after:=Sheets(Sheets.Count)
                ActiveSheet.Name = Tablo(I)
            End If
            On Error GoTo 0

            .Range("a5:ad" & Lg).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(nb).Range("A3")    'Sheets(Tablo(I)).Range("A3")
            nb = nb + 1
        Next I
        .AutoFilterMode = False
        .Select
    End With
End Sub

Cependant, ce code plante sur la ligne qui permet de sélectionner la feuille. En effet, le nom des feuilles est en colonne AD récupérer via un dictionnaire et transmis au tableau Tablo. Je suis bloqué merci pour votre aide.

 

[cp4]

Re

•>cp4
Où es le problème?
Tu vas calmer, garcon!
Je prends du temps pour essayer de t'aider et tu fais un caca nerveux?
Il y avait juste deux colonnes vides.
Je t'ai indiqué ce qu'il faut faire pour que le code soumis fonctionne.
J'ai simplement fais une coquille dans le message#11
Que j'ai corrigé suite à ton observation.
Tu n'aurais pas zappé le message#13 par hasard?

PS: Chacun est libre de ses mouvements sur XLD.

Il me semble que je t'ai poliment remercié pour le temps que tu m'as consacré et pour ton aide.
Je n'ai rien zappé.
Je te le redemande gentiment de ne plus intervenir dans mes discussions.
Autrement dit, Le garçon refusera ton aide.
Bon Dimanche.

 

[patricktoulon]

moi je me pose une question
pourquoi remplir un dictionnaire , en faire un tablo , et boucler sur le tablo
pourquoi pas boucler sur le dico directement 🙄

 

[Staple1600]

Bonjour patricktoulon

•>patricktoulon
J'ai pas le droit d'être là, mais je prends le gauche
(histoire de pouvoir te saluer😉)
Le stock de binch est à flot? 😉

 

[patricktoulon]

Salut Staple1600 😉 🙂
ben ca commence a reduire je vais devoir imprimer une attestation😛😛😛😛😛

 

[cp4]

Bonjour PatrickToulon 😉,

Comme je l'avais précisé au post#1 , j'ai trouvé sur le net le fichier qui ressemble à peu de choses au mien. J'ai donc pris ce code pour le comprendre et essayer de l'adapter à mon fichier.
Je me suis rendu compte que le code plantait, j'ai ouvert cette discussion le corriger et/ou l'améliorer.

Je le redis le code n'est pas le mien donc pour répondre à tes questions d'après ce que j'ai compris:
Le dico c'est pour récupérer sans doublons les données de la colonne AD, qui sont sensées être le nom des feuilles existantes ou éventuellement à créer si elles n'existent pas.

Passer le dico à un tableau, beaucoup de personnes font ça car je suppose que c'est plus facile de la faire une boucle avec Ubound.
Personnellement, je sais qu'on peut boucler sur le dictionnaire mais j'avoue que j'oublie la syntaxe.

Merci.
Bon Dimanche à toi.
ps: je reviendrai plus tard. Le confinement me pèse, je sors faire quelques foulées.

 

[patricktoulon]

re

for each elem in dico
msgbox "key =" & elem & vbcrlf & "items = " & dico(elem)
next

 

[Staple1600]

Re

Puisque je suis retourné dans VBE, en utilisant un Dico (comme dans l'exemple du message#1), je poste le résultat de mon test*
(histoire de pas gâcher)

Sub Eclater_Dico_cp4()
Dim F As Worksheet, ws As Worksheet, tablo, d As Object, i&, a
Set F = Worksheets("Base") '
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each ws In Worksheets
    If ws.Name <> F.Name Then ws.Delete
Next ws
tablo = F.[AB5].CurrentRegion.Columns(28).Resize(, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
    If tablo(i, 1) <> "" Then d(tablo(i, 1)) = ""
Next i
If d.Count = 0 Then Exit Sub
a = d.keys
With F.[A5].CurrentRegion
    For i = 0 To UBound(a)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = a(i)
        .AutoFilter 28, a(i)
        .Copy ActiveSheet.Cells(1)
    Next i
End With
F.AutoFilterMode = False
F.Activate
End Sub

Test OK toujours en partant de la plage A5:AB36
Si cela sert est utile à cp4, tant mieux. 😉

Sinon cela intéressera (may be) les potentiels futurs lecteurs de ce fil.

*: pour lequel, j'ai "adapté" un code de job75 posté dans un autre fil

 

[cp4]

re

for each elem in dico
msgbox "key =" & elem & vbcrlf & "items = " & dico(elem)
next

Merci beaucoup PatrickToulon 😉.