Extraire données en VBA dans BD avec Plusieurs critères sans Doublons

pmfontaine · 28 Décembre 2016

Bonsoir,
Je cherche comment réaliser l'extraction de données dans une BD avec Plusieurs critères sans les doublons. En plus de les extraire, je voudrais les compter.
Le fichier joint fait ce que je souhaite, mais pour atteindre le résultat, je fais une copie de la BD dans laquelle je supprime les doublons puis je récupère les données?
Pour le comptage j'ai mis une formule (ligne 6) qui compte dans la BD dupliquée sans Doublon.
J'ai plusieurs extractions a faire avec différents critères, je ne souhaite donc pas dupliquer X fois la BD et je pense que pour le comptage comme pour l'extraction des données ça dois être possible en VBA sans dupliquer la BD. Mais pour cela j'aurais besoins de votre aide.
Merci
Patrick

Modeste · 29 Décembre 2016

Bonjour pmfontaine,

Il me semble que j'obtiens les mêmes résultats que toi avec ceci:

VB:

Sub extraire()
With Sheets("BD")
  tabloBD = .Cells(2, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row - 1, 7)
End With
Set liste = CreateObject("scripting.dictionary")
Dim nbParMois(11)
With Sheets("RESULTAT")
  Cells(6, 2).Resize(WorksheetFunction.Max(.[B6:M6]), 12).ClearContents
  For i = 1 To UBound(tabloBD)
  If Not liste.exists(tabloBD(i, 2) & "#" & tabloBD(i, 5) & "#" & tabloBD(i, 6) & "#" & tabloBD(i, 7)) Then
  liste(tabloBD(i, 2) & "#" & tabloBD(i, 5) & "#" & tabloBD(i, 6) & "#" & tabloBD(i, 7)) = ""
  If tabloBD(i, 2) = .Cells(2, 1) And tabloBD(i, 3) = .Cells(4, 1) And tabloBD(i, 7) = .Cells(3, 2) Then
  nbParMois(tabloBD(i, 6) - 1) = nbParMois(tabloBD(i, 6) - 1) + 1
  .Cells(6 + nbParMois(tabloBD(i, 6) - 1), tabloBD(i, 6) + 1) = tabloBD(i, 5)
  End If
  End If
  Next i
  .Cells(6, 2).Resize(1, 12) = nbParMois
End With
End Sub

... à tester avec soin

pmfontaine · 30 Décembre 2016

Bonjour Modeste,
Merci pour ta réponse que je vais tester avec soin, comme tu le préconises.
Patrick

pmfontaine · 30 Décembre 2016

Re. bonjour,
A priorie ça marche bien, sauf cette ligne.

Code:

Cells(6, 2).Resize(WorksheetFunction.Max(.[B6:M6]), 12).ClearContents

Je pense avoir compris le fonctionnement du code, sauf pour la partie des mois si dessous.

Code:

nbParMois(tabloBD(i, 6) - 1) = nbParMois(tabloBD(i, 6) - 1) + 1
  .Cells(6 + nbParMois(tabloBD(i, 6) - 1), tabloBD(i, 6) + 1) = tabloBD(i, 5)

Est-ce qu'il serait possible d'avoir quelques commentaires, Merci
Patrick

Modeste · 30 Décembre 2016

Bonjour,

La première instruction que tu évoques ne fonctionne que si -au moins- une des valeurs en ligne 6 dépasse 0. Comme elle devrait permettre de mettre le tableau à blanc, avant d'y insérer les nouvelles données, tu peux la remplacer par:

VB:

Cells(6, 2).Resize(Cells(5, 2).CurrentRegion.Rows.Count, 12).ClearContents

Pour ce qui est de:

VB:

nbParMois(tabloBD(i, 6) - 1) = nbParMois(tabloBD(i, 6) - 1) + 1

nbParMois est un tableau de 12 éléments. Il contiendra les valeurs à afficher en ligne 6. La "colonne" concernée doit correspondre aux mois (de 1 à 12, donc) qui sont eux-mêmes renseignés dans la 6e colonne de ton tableau de départ. Pour le mois renseigné en colonne F de ta BD, la valeur pour ce mois est incrémentée d'une unité, à chaque passage dans la boucle. Le tableau représente donc un compteur par mois.

Sachant ce qui précède, à chaque passage dans la boucle For (et pour autant que les différentes conditions soient remplies), nbParMois(tabloBD(i, 6) - 1) renseignera donc le nombre d'oiseaux (ou mammifères, etc) observés à ce stade ... on peut donc en déduire le n° de ligne dans laquelle inscrire le nom du taxon. C'est ce que fait cette autre instruction:

VB:

.Cells(6 + nbParMois(tabloBD(i, 6) - 1), tabloBD(i, 6) + 1) = tabloBD(i, 5)

Le '6 +' au début de l'instruction permet de se positionner en ligne 7 pour le premier taxon, 8 pour le second, etc et ce à des "hauteurs" différentes pour chaque mois. Même principe pour le '+ 1', puisque janvier (mois 1) figure en colonne 2, et ainsi de suite.

Est-ce clair? (peut-être pas intuitif, j'en conviens, mais que diable, nul n'est parfait ... contrairement à ce que certains pensent )

klin89 · 30 Décembre 2016

Bonsoir pmfontaine, modeste

Une autre façon de présenter "la chose"
Au préalable, créer la Feuil1

VB:

Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, txt As String, txt1 As String
Dim dico As Object
    Set dico = CreateObject("scripting.dictionary")
    dico.CompareMode = 1
    With Sheets("RESULTAT")
        txt1 = Join$(Array(.Range("a2").Value, .Range("a4").Value, .Range("b3").Value), Chr(2))
    End With
    dico(txt1) = Empty
    With Sheets("BD").Range("a1").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 7)), Chr(2))
            If dico.exists(txt) Then
                If IsEmpty(dico(txt)) Then
                    ReDim w(1 To 2)
                    ReDim x(1 To 13, 1 To 2)
                    x(1, 1) = Split(txt, Chr(2))(2) & " - " & Split(txt, Chr(2))(0) & " - " & Split(txt, Chr(2))(1)
                    For j = 1 To 12
                        x(j + 1, 1) = MonthName(j)
                    Next
                    Set w(2) = CreateObject("Scripting.Dictionary")
                    w(2).CompareMode = 1
                Else
                    w = dico(txt)
                    x = w(1)
                End If
                If Not w(2).exists(a(i, 5)) Then
                    w(2)(a(i, 5)) = Empty
                    ReDim Preserve x(1 To 13, 1 To UBound(x, 2) + 1)
                    x(1, UBound(x, 2) - 1) = a(i, 5)
                End If
                x(Application.Match(MonthName(a(i, 6)), Application.Index(x, , 1), 0), Application.Match(a(i, 5), Application.Index(x, 1), 0)) = "x"
                w(1) = x
                dico(txt) = w
            End If
        Next
        If Not IsEmpty(dico(txt1)) Then
            w = dico(txt1): x = w(1)
            x(1, UBound(x, 2)) = "Nombre d'espèces observées"
            For i = 2 To UBound(x, 1)
                x(i, UBound(x, 2)) = Application.CountA(Application.Index(x, i, Evaluate("row(2:" & UBound(x, 2) - 1 & ")")))
            Next
            w(1) = x: dico(txt1) = w
        End If
    End With
    'Restitution en Feuil1
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("a1")
        .CurrentRegion.Clear
        If IsEmpty(dico(txt1)) Then
            MsgBox "Pas d'espèces observées"
        Else
            w = dico(txt1)(1)
            With .Resize(UBound(w, 2), UBound(w, 1))
                .Value = Application.Transpose(w)
                .Font.Size = 10
                .Rows(1).BorderAround Weight:=xlThin
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                With .Offset(1).Resize(.Rows.Count - 2, 1)
                    .Interior.ColorIndex = 36
                End With
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .HorizontalAlignment = xlCenter
                    .Columns.ColumnWidth = 8
                End With
                With .Offset(, 1).Resize(1, .Columns.Count - 1)
                    .Interior.ColorIndex = 44
                End With
                With .Rows(.Rows.Count)
                    .BorderAround Weight:=xlThin
                    With .Offset(, 1).Resize(, .Columns.Count - 1)
                        .Interior.ColorIndex = 35
                    End With
                End With
                .Columns(1).AutoFit
            End With
        End If
        .Parent.Activate
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

klin89 · 1 Janvier 2017

Bonjour et bonne année à tous,

Sur ma lancée, j'ai rajouté une colonne et fait le total par espèces

VB:

Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, txt As String, txt1 As String
Dim dico As Object
    Set dico = CreateObject("scripting.dictionary")
    dico.CompareMode = 1
    With Sheets("RESULTAT")
        txt1 = Join$(Array(.Range("a2").Value, .Range("a4").Value, .Range("b3").Value), Chr(2))
    End With
    dico(txt1) = Empty
    With Sheets("BD").Range("a1").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 7)), Chr(2))
            If dico.exists(txt) Then
                If IsEmpty(dico(txt)) Then
                    ReDim w(1 To 2)
                    ReDim x(1 To 14, 1 To 2)
                    x(1, 1) = Split(txt, Chr(2))(2) & " - " & Split(txt, Chr(2))(0) & " - " & Split(txt, Chr(2))(1)
                    For j = 1 To 12
                        x(j + 1, 1) = MonthName(j)
                    Next
                    Set w(2) = CreateObject("Scripting.Dictionary")
                    w(2).CompareMode = 1
                Else
                    w = dico(txt)
                    x = w(1)
                End If
                If Not w(2).exists(a(i, 5)) Then
                    w(2)(a(i, 5)) = Empty
                    ReDim Preserve x(1 To 14, 1 To UBound(x, 2) + 1)
                    x(1, UBound(x, 2) - 1) = a(i, 5)
                End If
                x(Application.Match(MonthName(a(i, 6)), Application.Index(x, , 1), 0), Application.Match(a(i, 5), Application.Index(x, 1), 0)) = "x"
                w(1) = x
                dico(txt) = w
            End If
        Next
        If Not IsEmpty(dico(txt1)) Then
            w = dico(txt1): x = w(1)
            x(1, UBound(x, 2)) = "Nombre d'espèces observées"
            x(UBound(x, 1), 1) = "Nombre de l'espèce observée"
            For i = 2 To UBound(x, 1) - 1
                x(i, UBound(x, 2)) = Application.CountA(Application.Index(x, i, Evaluate("row(2:" & UBound(x, 2) - 1 & ")")))
            Next
            For i = 2 To UBound(x, 2) - 1
                x(UBound(x, 1), i) = Application.CountA(Application.Index(x, Evaluate("row(2:" & UBound(x, 1) - 1 & ")"), i))
            Next
            x(UBound(x, 1), UBound(x, 2)) = Application.Sum(Application.Index(x, UBound(x, 1), Evaluate("row(2:" & UBound(x, 2) - 1 & ")")))
            w(1) = x: dico(txt1) = w
        End If
    End With
    'Restitution en Feuil1
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("a1")
        .CurrentRegion.Clear
        If IsEmpty(dico(txt1)) Then
            MsgBox "Pas d'espèces observées"
        Else
            w = dico(txt1)(1)
            With .Resize(UBound(w, 2), UBound(w, 1))
                .Value = Application.Transpose(w)
                .Font.Size = 10
                .Rows(1).BorderAround Weight:=xlThin
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                With .Offset(1).Resize(.Rows.Count - 2, 1)
                    .Interior.ColorIndex = 36
                End With
                With .Offset(, 1).Resize(1, .Columns.Count - 1)
                    .Interior.ColorIndex = 44
                End With
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .HorizontalAlignment = xlCenter
                    .Columns.ColumnWidth = 8
                End With
                With .Rows(.Rows.Count)
                    .BorderAround Weight:=xlThin
                    With .Resize(, .Columns.Count - 1)
                        .Interior.ColorIndex = 35
                    End With
                End With
                .Columns(1).AutoFit
                .Columns(.Columns.Count).AutoFit
            End With
        End If
        .Parent.Activate
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

pmfontaine · 2 Janvier 2017

Bonjour et bonne année à tous.
Merci Modeste, Merci Klin89 pour vos réponses et désolé de ne pas avoir réponse avant avant mais avec les fêtes j'ai mis un peu de coté Excel. Mais maintenant je mis remets.
Pour le moment je ne pas regardé vos réponses en détail, je vais les regarder et je reviens poster vous dire si c'est bon et surtout si j'ai compris le code.
Encore Merci pour votre aide et bonne semaine.
Patrick

pmfontaine · 8 Janvier 2017

Bonjour,
Le code de klin89 est effectivement intéressant, mais la proposition de Modeste, correspond mieux a mon souhait. Je vais donc utiliser son code.
Merci
Patrick

Extraire données en VBA dans BD avec Plusieurs critères sans Doublons

pmfontaine

XLDnaute Occasionnel

Pièces jointes

Modeste

XLDnaute Barbatruc

pmfontaine

XLDnaute Occasionnel

pmfontaine

XLDnaute Occasionnel

Modeste

XLDnaute Barbatruc

klin89

XLDnaute Accro

klin89

XLDnaute Accro

pmfontaine

XLDnaute Occasionnel

pmfontaine

XLDnaute Occasionnel

Discussions similaires