Autres [Discussion Close]

cp4 · 22 Mars 2020

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.

VB:

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.

Staple1600 · 22 Mars 2020

Bonjour le fil, cp4

•>cp4
Quel est ton besoin?
Quel est le motif de l'absence d'un fichier joint?
(Pas besoin d'attestation dérogatoire pour ce faire: c'est pas dans liste des motifs pour braver le confinement )

cp4 · 22 Mars 2020

Bonjour JM,

Content que tu me répondes. Non, je ne joindrai pas cette fois-ci de fichier.
Je voudrai juste que tu m'aides à résoudre le problème poser. une fois ce dernier résolu.
J'ai l'intention d'essayer d'adapter tout seul (comme un grand) à mon besoin.
Si je n'y parviens pas, j'ouvrirai une discussion pour solliciter de l'aide.

Merci bien. Bon dimanche.

cp4 · 22 Mars 2020

Re,

Je viens de résoudre le problème avec ceci Sheets(CStr(Tablo(I))).Select
mais un second survient, plantage plus bas lors de l'ajout d'une nouvelle feuille et donc impossible d'avoir le même nom.
Bon! je me résous à joindre le fichier.

Staple1600 · 22 Mars 2020

Re

Très bien.
En l'état, je n'ai pas assez d'éléments pour tester le code du message#1
D'où la demande d'un fichier exemple pour faire des tests.
Je vais donc proposer mon aide ailleurs
Là où le demandeur se donne les moyens de faciliter la résolution de sa question

Bon dimanche.

cp4 · 22 Mars 2020

Staple1600 à dit:
Re

Très bien.
En l'état, je n'ai pas assez d'éléments pour tester le code du message#1
D'où la demande d'un fichier exemple pour faire des tests.
Je vais donc proposer mon aide ailleurs
Là où le demandeur se donne les moyens de faciliter la résolution de sa question

Bon dimanche.

Tu as zappé le post#4.
Aucun souci. Bon dimanche à toi aussi.

Staple1600 · 22 Mars 2020

Re

•>cp4
Non, j'ai vu le message#4 et j'ai donc téléchargé ton fichier
Si j'ai compris ton besoin: tu veux éclater les données de l'onglet Base en te basant sur le contenu de la colonne Travée.

NB: Les feuilles sont déjà existantes ou il faut les créer à la volée ?

cp4 · 22 Mars 2020

Staple1600 à dit:
Re

•>cp4
Non, j'ai vu le message#4 et j'ai donc téléchargé ton fichier
Si j'ai compris ton besoin: tu veux éclater les données de l'onglet Base en te basant sur le contenu de la colonne Travée.

NB: Les feuilles sont déjà existantes ou il faut les créer à la volée ?

Exactement, tu as bien compris. Pour les feuilles il faudrait les ajouter si elles n'existent pas.
En modifiant comme ceci : Err.number <0 (car debug.printerr.number renvoyé 9) ne plante plus (est-ce la bonne correction).
Autre chose constatée dans le code, l'activation de la feuille se fait en passant par le nom et plus bas pour la recopier utilisation de l'index des feuilles d’où un plantage.
Merci.

Staple1600 · 22 Mars 2020

Re

1) mon dictionnaire je le laisse dans ma bibliothèque.
2) je réagence tes données comme il se doit (Base oblige )
3) je teste la macro ci-dessous.
Et je peux alors écrire: test OK

VB:

Sub Eclater_Base_cp4()
Dim f As Worksheet, c As Range
Set f = Sheets("Base"): f.[AD5].Value = "Travée"
f.[A5].CurrentRegion.Columns(28).AdvancedFilter Action:=2, CopyToRange:=f.[AD5], Unique:=-1
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For Each c In Range(f.Cells(6, "AD"), f.Cells(Rows.Count, "AD").End(3))
f.[AD6] = c.Value
On Error Resume Next: Sheets(c.Value).Delete: On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count): ActiveSheet.Name = c.Value
f.[A5].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[AD5:AD6], CopyToRange:=[A1]
Next c
f.[AD5].CurrentRegion.Clear: f.Activate
End Sub

cp4 · 22 Mars 2020

Staple1600 à dit:

Re

1) mon dictionnaire je le laisse dans ma bibliothèque.
2) je réagence tes données comme il se doit (Base oblige )
3) je teste la macro ci-dessous.
Et je peux alors écrire: test OK

VB:

Sub Eclater_Base_cp4()
Dim f As Worksheet, c As Range
Set f = Sheets("Base"): f.[AD5].Value = "Travée"
f.[A5].CurrentRegion.Columns(28).AdvancedFilter Action:=2, CopyToRange:=f.[AD5], Unique:=-1
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For Each c In Range(f.Cells(6, "AD"), f.Cells(Rows.Count, "AD").End(3))
f.[AD6] = c.Value
On Error Resume Next: Sheets(c.Value).Delete: On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count): ActiveSheet.Name = c.Value
f.[A5].CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[AD5:AD6], CopyToRange:=[A1]
Next c
f.[AD5].CurrentRegion.Clear: f.Activate
End Sub

Merci beaucoup, mais pas OK.
Tu as modifié tout le code. Je voulais juste corriger et/ou compléter le code initial. Merci pour le temps que tu me consacres.

Staple1600 · 22 Mars 2020

Re

Oui, j'occupe mon confinement comme je le souhaite
Je fais du VBA.
Ensuite je le poste sur XLD et le demandeur en dispose ou pas

Pour l'erreur, voir le point 2) du message précedent

Dans une base de donnée, il ne doit pas y avoir de colonne vide.
Donc mon réagencement a consister à les supprimer.

Ta base doit être dans la plage A5:AB36 pour que mon code fonctionne

cp4 · 22 Mars 2020

Staple1600 à dit:
Re

Oui, j'occupe mon confinement comme je le souhaite
Je fais du VBA.
Ensuite je le poste sur XLD et le demandeur en dispose ou pas

Pour l'erreur, voir le point 2) du message précedent

Dans une base de donnée, il ne doit pas y avoir de colonne vide.
Donc mon réagencement a consister à les supprimer.

Ta base doit être dans la plage A5:AD36 pour que mon code fonctionne

Ok, mais pourquoi dans cette ligne de code
f.[A5].CurrentRegion.Columns(28).AdvancedFilter Action:=2, CopyToRange:=f.[AD5], Unique:=-1
alors que le numéro de la colonne AD et 30.
Merci beaucoup.

Staple1600 · 22 Mars 2020

Re

Désolé, erreur de saisie, il fallait lire

Ta base doit être dans la plage A5:AB36 pour que mon code fonctionne.

PS: j'ai fait la correction dans le précédent message.

cp4 · 22 Mars 2020

Je déduis qu'il faut que je réduise ma bd pour utiliser ton code.
Merci de m'avoir fait perdre mon temps.
Dans ton post#11, tu me dis en quelque sorte que tu t’éclates bien sur XLD. Et tant mieux pour toi.
Je t'en serai gré de ne plus intervenir dans mes discussions.

Staple1600 · 22 Mars 2020

Re

•>cp4
Où es le problème?
Tu vas te calmer, garcon!
Et respirer un grand coup!

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.

Autres [Discussion Close]

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Pièces jointes

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Discussions similaires