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: 24
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

7
  • Question
Microsoft 365 Tableau de Géolocalisation de vidéos de drone avec lien vers Google Earth
2
Réponses
15
Affichages
635
sylvanu
sylvanu
C
  • Question
XL 2016 Excel Macro permettant de masquer une ligne lorsque les cellules de 2 colonnes contigües sont vides
Réponses
11
Affichages
282
chris63
C
cathodique
  • Résolu(e)
XL 2010 tableau de comptage sans doublon
2 3
Réponses
44
Affichages
2 K
cathodique
cathodique
M
  • Question
Autres Copier la ligne complète d’un tableau dans un autre tableau sous condition
Réponses
1
Affichages
255
djidji59430
djidji59430
A
  • Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
280
sylvanu
sylvanu
Adexa
  • Question
XL 2019 Rechercher un libellé approximatif dans un tableau et afficher une valeur
2
Réponses
29
Affichages
846
Dudu2
Dudu2
C
  • Résolu(e)
XL 2019 Mettre un "X" automatiquement dans une cellule selon critères valeurs sur la même ligne
Réponses
12
Affichages
399
ced91300
C
J
  • Question
Microsoft 365 création de boucle et suppression de ligne si une cellule est vide
Réponses
2
Affichages
392
JVOS
J
A
  • Question
XL 2019 Ajouter ou supprimer une ligne selon un mot trouvé dans une autre feuille
Réponses
1
Affichages
376
Oneida
Oneida
L
  • Question
XL pour MAC tableau ans perturbation des colonnes non copié
Réponses
5
Affichages
589
DJunqueira
D

Membres actuellement en ligne

14 membres et 74 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
315 091
Messages
2 116 111
Membres
112 662
dernier inscrit
lou75