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

L

Loïc DUBOIS

XLDnaute Occasionnel
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: 23
Trier par date Trier par votes
vgendron

vgendron

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

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)
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
L

Loïc DUBOIS

XLDnaute Occasionnel
job75 à dit:
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+
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
L

Loïc DUBOIS

XLDnaute Occasionnel
job75 à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
L

Loïc DUBOIS

XLDnaute Occasionnel
job75 à dit:
Avez-vous testé mon fichier (2) et donne-t-il les bons résultats ?
Cliquez pour agrandir...
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,
 
Vote positif 0 Vote négatif
B

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 !
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2019 Ajouter ou supprimer une ligne selon un mot trouvé dans une autre feuille
Réponses
1
Affichages
150
Oneida
Oneida
L
  • Question
XL pour MAC tableau ans perturbation des colonnes non copié
Réponses
5
Affichages
279
DJunqueira
D
C
  • Question
XL 2019 vba excel : masquer un tableau word
Réponses
9
Affichages
356
CBX
C
B
  • Question
XL 2016 Macro pour identifier un texte dans un tableau et appliquer une modification sur une cellule sur la même ligne
Réponses
5
Affichages
251
ChTi160
ChTi160
M
  • Question
Power Query Convertir un fichier Contacts Gmail et fichier Excel
Réponses
13
Affichages
392
nat54
nat54
Roseline
  • Résolu(e)
Microsoft 365 Trouver la dernière ligne de tous les onglets par VBA
Réponses
4
Affichages
232
job75
job75
B
  • Question
XL 2016 VBA formulaire incrémenter un N° de facture selon l'année(mais dates sur deux colonnes)
Réponses
4
Affichages
234
badduke
B
M
  • Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
558
ManuXZ
M
S
  • Question
XL 2019 Regroupement données dans un tableau
2
Réponses
18
Affichages
565
Shimano
S
L
  • Question
XL 2019 Formule ou VBA intersection tableau selon deux colonnes et une ligne
Réponses
7
Affichages
544
Hasco
Hasco

Membres actuellement en ligne

15 membres et 110 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 207
Messages
2 086 231
Membres
103 161
dernier inscrit
Rogombe bryan