XL 2019 Trouver la data correspondant selon un tableau ; deux colonnes et une ligne.

Loïc DUBOIS

XLDnaute Junior
Bonjour à tous,

J'espère que vous allez tous bien ?

Mon problème est que je souhaite réaliser une collecte de données via une base de données. Pour se faire j’ai mon fichier de base qui contient toutes mes données.

Ensuite j’ai mon fichier voulu (feuil2) qui contient toutes mes entreprises (liste) et je souhaite mettre toutes mes données dans mon fichier voulu (feuil2) sous forme d’une liste (colonne 1 : entreprise; colonne 2 : variable 1 ; colonne 3 : variable 3 etc).

Pour se faire dans ma liste des entreprises j’ai comme infos le numéro de tableau ou se trouve l’entreprise (fichier de base (feuil1) avec le nom de l’entreprise et la date souhaité. En sachant que la date souhaité (se trouve sur la première ligne de chaque tableau) est différente selon chaque tableau (j’ai 49 tableaux différents sur une seule feuille de calcul avec 14 variables différentes(fichier de base).

Je voudrais donc savoir s’il existe une formule excel me permettant de retrouver ma donnée selon le numéro de tableau (colonne A feuil2), le nom de la variable (M1, N1 et O1 (feuil2), le nom de l’entreprise (colonne B feuil2) (critère colonne) et selon la ligne (date) (il y a une ligne de date par tableau).

Ou un code VBA (en m’expliquant quelle critère je dois changer pour adapter à un fichier de plus de 400000 lignes et plus de 14 variables).



Merci d’avance



Je vous met un fichier joint en exemple.
PS : Je préfererais une formule excel si possible car je ne suis pas très à l'aide avec le code VBA (modifier le code pour mon cas général...)
 

Pièces jointes

  • test forum final.xlsx
    130.2 KB · Affichages: 22

vgendron

XLDnaute Barbatruc
Hello
Par exemple, les datas sont mélangés (Total revenue devait être dans la colonne M (première variable)

Tu as mal lu ma note 2 au post 26
il faut que les colonnes (les 14 critères) soient triés dans l'ordre alpha pour que ca corresponde aux données des tables 'Tabb_xx" qui sont aussi triées en ordre alpha dans la macro (avec le QuickSort)
 

job75

XLDnaute Barbatruc
Bonjour Loïc DUBOIS, vgendron, le forum,

Je reviens sur ce fil avec une solution pas trop difficile à comprendre (il faut quand même s'accrocher) :
VB:
Sub MAJ_Feuil2()
Dim t, d As Object, dd As Object, P As Range, tablo, ub%, resu(), i&, dat As Variant, x$, j%, y$, lig&, col%(), k%, ubcol%
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
'---analyse de Feuil2---
Set P = Sheets("Feuil2").UsedRange.Resize(, 26)
tablo = P 'matrice, plus rapide
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo) - 1, 1 To ub - 12)
For i = 2 To UBound(tablo)
    dat = tablo(i, 12)
    If IsDate(dat) Then dd(tablo(i, 1) & Chr(1) & dat) = ""
    x = Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 12)
    For j = 13 To ub
        y = tablo(i, 1) & Chr(1) & tablo(1, j) & x
        d(y) = ""
        resu(i - 1, j - 12) = y
Next j, i
'---analyse de Feuil1---
tablo = Sheets("Feuil1").UsedRange 'matrice, plus rapide
ub = UBound(tablo, 2)
lig = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then
        If tablo(i - 1, 1) = "" Then lig = i 'ligne des dates
        If i > lig Then
            If i = lig + 1 Then
                k = 0
                '---mémorise les colonnes à utiliser pour gagner du temps---
                For j = 4 To ub
                    If dd.exists(x & Chr(1) & tablo(lig, j)) Then ReDim Preserve col(k): col(k) = j: k = k + 1
                Next j
                ubcol = UBound(col)
            End If
            x = x & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3) & Chr(1)
            For k = 0 To ubcol
                y = x & tablo(lig, col(k))
                If d.exists(y) Then d(y) = tablo(i, col(k)) 'mémorise la valeur
            Next k
        End If
    End If
Next i
'---résultats---
ub = UBound(resu, 2)
For i = 1 To UBound(resu)
    For j = 1 To ub
        resu(i, j) = d(resu(i, j))
Next j, i
P(2, 13).Resize(UBound(resu), ub) = resu 'restitution sur la feuille
MsgBox "MAJ réalisée en " & Format(Timer - t, "0.00 \sec")
End Sub
La macro est très rapide grâce aux tableaux VBA et aux 2 Dictionary => 0,05 seconde chez moi.

A+
 

Pièces jointes

  • test forum final(1).xlsm
    595.5 KB · Affichages: 6

Loïc DUBOIS

XLDnaute Junior
Bonjour Loïc DUBOIS, vgendron, le forum,

Je reviens sur ce fil avec une solution pas trop difficile à comprendre (il faut quand même s'accrocher) :
VB:
Sub MAJ_Feuil2()
Dim t, d As Object, dd As Object, P As Range, tablo, ub%, resu(), i&, dat As Variant, x$, j%, y$, lig&, col%(), k%, ubcol%
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dd = CreateObject("Scripting.Dictionary")
'---analyse de Feuil2---
Set P = Sheets("Feuil2").UsedRange.Resize(, 26)
tablo = P 'matrice, plus rapide
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo) - 1, 1 To ub - 12)
For i = 2 To UBound(tablo)
    dat = tablo(i, 12)
    If IsDate(dat) Then dd(tablo(i, 1) & Chr(1) & dat) = ""
    x = Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 12)
    For j = 13 To ub
        y = tablo(i, 1) & Chr(1) & tablo(1, j) & x
        d(y) = ""
        resu(i - 1, j - 12) = y
Next j, i
'---analyse de Feuil1---
tablo = Sheets("Feuil1").UsedRange 'matrice, plus rapide
ub = UBound(tablo, 2)
lig = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then
        If tablo(i - 1, 1) = "" Then lig = i 'ligne des dates
        If i > lig Then
            If i = lig + 1 Then
                k = 0
                '---mémorise les colonnes à utiliser pour gagner du temps---
                For j = 4 To ub
                    If dd.exists(x & Chr(1) & tablo(lig, j)) Then ReDim Preserve col(k): col(k) = j: k = k + 1
                Next j
                ubcol = UBound(col)
            End If
            x = x & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3) & Chr(1)
            For k = 0 To ubcol
                y = x & tablo(lig, col(k))
                If d.exists(y) Then d(y) = tablo(i, col(k)) 'mémorise la valeur
            Next k
        End If
    End If
Next i
'---résultats---
ub = UBound(resu, 2)
For i = 1 To UBound(resu)
    For j = 1 To ub
        resu(i, j) = d(resu(i, j))
Next j, i
P(2, 13).Resize(UBound(resu), ub) = resu 'restitution sur la feuille
MsgBox "MAJ réalisée en " & Format(Timer - t, "0.00 \sec")
End Sub
La macro est très rapide grâce aux tableaux VBA et aux 2 Dictionary => 0,05 seconde chez moi.

A+
Merci beaucoup Job75,

Néanmoins lorsque je tente de faire votre code, j'ai un message d'erreur :
1674414410274.png


Savez-vous ce qui coince ?

Merci d'avance,

Loïc
 

job75

XLDnaute Barbatruc
Bon, cette macro utilise 2 collections, testez ce fichier (2) :
VB:
Option Compare Text 'la casse est ignorée

Sub MAJ_Feuil2()
Dim t, c As New Collection, cc As New Collection, P As Range, tablo, ub%, resu(), i&, dat As Variant, x$, j%, y$, lig&, col%(), k%, ubcol%
t = Timer
'---analyse de Feuil2---
Set P = Sheets("Feuil2").UsedRange.Resize(, 26)
tablo = P 'matrice, plus rapide
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo) - 1, 1 To ub - 12)
On Error Resume Next 'nécessaire avec les collections
For i = 2 To UBound(tablo)
    dat = tablo(i, 12)
    If IsDate(dat) Then cc.Add "", tablo(i, 1) & Chr(1) & dat
    x = Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 12)
    For j = 13 To ub
        y = tablo(i, 1) & Chr(1) & tablo(1, j) & x
        c.Add "", y
        resu(i - 1, j - 12) = y
Next j, i
'---analyse de Feuil1---
tablo = Sheets("Feuil1").UsedRange 'matrice, plus rapide
ub = UBound(tablo, 2)
lig = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then
        If tablo(i - 1, 1) = "" Then lig = i 'ligne des dates
        If i > lig Then
            If i = lig + 1 Then
                k = 0
                '---mémorise les colonnes à utiliser pour gagner du temps---
                For j = 4 To ub
                    If cc(x & Chr(1) & tablo(lig, j)) <> "" Then Else ReDim Preserve col(k): col(k) = j: k = k + 1
                Next j
                ubcol = UBound(col)
            End If
            x = x & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3) & Chr(1)
            For k = 0 To ubcol
                y = x & tablo(lig, col(k))
                If c(y) <> "" Then Else c.Remove y: c.Add tablo(i, col(k)), y 'mémorise la valeur
            Next k
        End If
    End If
Next i
'---résultats---
ub = UBound(resu, 2)
For i = 1 To UBound(resu)
    For j = 1 To ub
        resu(i, j) = c(resu(i, j))
Next j, i
P(2, 13).Resize(UBound(resu), ub) = resu 'restitution sur la feuille
MsgBox "MAJ réalisée en " & Format(Timer - t, "0.00 \sec")
End Sub
Chez moi la durée d'exécution ne change pas, c'est toujours 0,05 seconde.
 

Pièces jointes

  • test forum final(2).xlsm
    595.5 KB · Affichages: 2

Loïc DUBOIS

XLDnaute Junior
Bon, cette macro utilise 2 collections, testez ce fichier (2) :
VB:
Option Compare Text 'la casse est ignorée

Sub MAJ_Feuil2()
Dim t, c As New Collection, cc As New Collection, P As Range, tablo, ub%, resu(), i&, dat As Variant, x$, j%, y$, lig&, col%(), k%, ubcol%
t = Timer
'---analyse de Feuil2---
Set P = Sheets("Feuil2").UsedRange.Resize(, 26)
tablo = P 'matrice, plus rapide
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo) - 1, 1 To ub - 12)
On Error Resume Next 'nécessaire avec les collections
For i = 2 To UBound(tablo)
    dat = tablo(i, 12)
    If IsDate(dat) Then cc.Add "", tablo(i, 1) & Chr(1) & dat
    x = Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 12)
    For j = 13 To ub
        y = tablo(i, 1) & Chr(1) & tablo(1, j) & x
        c.Add "", y
        resu(i - 1, j - 12) = y
Next j, i
'---analyse de Feuil1---
tablo = Sheets("Feuil1").UsedRange 'matrice, plus rapide
ub = UBound(tablo, 2)
lig = 1
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then
        If tablo(i - 1, 1) = "" Then lig = i 'ligne des dates
        If i > lig Then
            If i = lig + 1 Then
                k = 0
                '---mémorise les colonnes à utiliser pour gagner du temps---
                For j = 4 To ub
                    If cc(x & Chr(1) & tablo(lig, j)) <> "" Then Else ReDim Preserve col(k): col(k) = j: k = k + 1
                Next j
                ubcol = UBound(col)
            End If
            x = x & Chr(1) & tablo(i, 2) & Chr(1) & tablo(i, 3) & Chr(1)
            For k = 0 To ubcol
                y = x & tablo(lig, col(k))
                If c(y) <> "" Then Else c.Remove y: c.Add tablo(i, col(k)), y 'mémorise la valeur
            Next k
        End If
    End If
Next i
'---résultats---
ub = UBound(resu, 2)
For i = 1 To UBound(resu)
    For j = 1 To ub
        resu(i, j) = c(resu(i, j))
Next j, i
P(2, 13).Resize(UBound(resu), ub) = resu 'restitution sur la feuille
MsgBox "MAJ réalisée en " & Format(Timer - t, "0.00 \sec")
End Sub
Chez moi la durée d'exécution ne change pas, c'est toujours 0,05 seconde.
Merci beaucoup pour le temps que vous me consacrez.
J'ai testé mais j'ai un problème. En effet, lorsque j'active la macro sur mon fichier, cela me met 43 seconde pour exécuter la macro (donc pas de soucis pour le moment). Cependant, je n'ai absolument aucun résultats qui s'affiche...

Ai-je loupé quelque chose ?

Avez vous une idée ?

Merci
 

Loïc DUBOIS

XLDnaute Junior
Avez-vous testé mon fichier (2) et donne-t-il les bons résultats ?
Oui j'ai testé. La macro s'exécute dans son intégralité (en 43sec) mais aucun résultats ne s'affichent ...
Il y a t-il des pré requis qui pourraient expliquer ce problème ?

Je pense que mon fichier est similaire à mon fichier exemple mais peut-être que je loupe quelque chose ?

merci d'avance,
 

Backhandshot

XLDnaute Occasionnel
Bonsoir à tous !
Job75,
Moi aussi j'ai testé les 2 macros la première me dit

VB:
 erreur 9 l'indice n'appartient pas à la sélection
ubcol = UBound(col)

et la 2ième, la macro s'exécute en 0.05 sec mais rien ne s'affiche
J'utilise un PC et Windows

Bonne soirée !
 

Discussions similaires

Réponses
8
Affichages
203

Statistiques des forums

Discussions
308 312
Messages
2 053 584
Membres
233 671
dernier inscrit
Romain11