Discussion :

[nivk-539]

Bonjour le forum,

J'ai un classeur avec une feuille correspondant à une base de données et une autre où j'extrait la base de données en fonction de ce que j'écris dans range("A3").
Pour extraire je n'ai pas de soucis mais j'ai un blocage pour séparer mon tableau. Je mets le fichier en pj où j'explique sur la feuil1 ce que je voudrais ça sera plus simple.

[Menhir]

ça sera plus simple.

A condition que quelqu'un l'ouvre. https://www.developpez.net/forums/d8...s-discussions/

[nivk-539]

En effet je m'excuse j'avais oublié cette règle...
Je m'explique :
Du coup dans ma feuille "BDD" j'ai une base de données.
Sur ma feuille extraction, j'entre par exemple "LLLLLLLLL-6" ce qui va m'extraire toute ma base correspondant au "LLLLLLLLL".
Ensuite dans ma colonne R13, j'ai des lettres différentes (C,D,E). Ainsi en cliquant sur le bouton "Défusionner", mon tableau se sépare en fonction de chacune de ces lettres.

Quand j'extrais j'ai ça :


Ensuite quand je clique sur défusionner j'ai ça:


alors que je voudrais ceci:


Voici mon code pour défusionner :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Sub Defusionner()
 
Application.ScreenUpdating = False
Dim PremValR13 As String
Dim Cell As Range, PlageR13 As Range, Rng As Range
Dim DerLiR13 As Integer, NbCol As Integer, NbRow As Integer
Dim CopyRange As Range, PasteRange As Range
Dim n As Integer
Dim lstrow As Integer, DerLi As Integer
 
With Worksheets("Extraction")
 
    PremValR13 = .Range("Q20")
    DerLiR13 = .Range("Q65536").End(xlUp).Row
    Set PlageR13 = .Range("Q20:Q" & DerLiR13)
    PremLig = Range("D" & DerLiR13 + 1).End(xlDown).Row
 
    'Ici je fusionne la plage de cellules n'ayant pas la même valeur que Q20
    For Each Cell In PlageR13
        If Cell.Value <> PremValR13 Then
            cpt = cpt + 1
            If cpt = 1 Then
                Set PlageR13 = Cell
            Else
                Set PlageR13 = Union(PlageR13, Cell)
            End If
        End If
    Next Cell
 
    Range(PlageR13, PlageR13.Offset(0, -13)).Select
 
    'Procédure pour séparer ma plage fusionnée
    Set f = Sheets("Extraction")
    DerLi = f.[Q65000].End(xlUp).Row
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    bd = Selection
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(bd): d(bd(i, 14)) = d(bd(i, 14)) & i & ",": Next
    ligne = DerLi + 4
    f.Cells(ligne, "f").Resize(1000, 14).ClearContents
    For Each k In d.keys
    lstrow = f.[Q65000].End(xlUp).Row
    lstrow = lstrow + 4
       Cells(ligne - 1, "d") = f.[d19]
       Cells(ligne - 1, "e") = f.[e19]
       Cells(ligne - 1, "f") = f.[f19]
       Cells(ligne - 1, "g") = f.[g19]
       Cells(ligne - 1, "h") = f.[h19]
       Cells(ligne - 1, "i") = f.[i19]
       Cells(ligne - 1, "j") = f.[j19]
       Cells(ligne - 1, "k") = f.[k19]
       Cells(ligne - 1, "l") = f.[l19]
       Cells(ligne - 1, "m") = f.[m19]
       Cells(ligne - 1, "n") = f.[n19]
       Cells(ligne - 1, "o") = f.[o19]
       Cells(ligne - 1, "p") = f.[p19]
       Cells(ligne - 1, "q") = f.[q19]
       a = Application.Index(bd, Application.Transpose(Split(d.Item(k), ",")), Array(1, 14))
       f.Cells(ligne, "d").Resize(UBound(a) - 1, UBound(a, 2)) = a
       ligne = ligne + UBound(a) + 1
    Next k
 
Selection.Rows.Delete
Range("A1").Select
 
End With
 
End Sub

[Philippe Tulliez]

Bonjour,
Tu peux régler cela en deux étapes avec la méthode AdvancedFilter voir fil https://www.developpez.net/forums/d1...l/#post7190633

[nivk-539]

C'est bon en fait désolé c'est juste que j'avais mal compris mon Array.

J'ai juste rajouté :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

a = Application.Index(bd, Application.Transpose(Split(d.Item(k), ",")), Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14))