XL 2013 Boucle Index Equiv en VBA sur plusieurs Feuilles

[r3dkross]

Bonjour à tous, bonjour le forum,

Je reviens vers vous pour un petit coup de main en vba!

Je souhaite convertir une formule en vba car elle ralentit mon classeur entier, je réalise des imports jusqu’à 250000 lignes parfois. Voici la structure rapide de mon problème:

je souhaite remplir la colonne « commune à trouver » sur la feuille « data » à partir de la clé de recherche du même tableau en allant chercher dans la feuille « CléCommunes » la commune associée à la clé.
En cas d’erreur je recherche les 5 premiers caractères de la clé avec une fonction gauche.

tout fonctionne très bien en formule mais je n’arrive pas à le faire en vba, voici mon code:

sub recherchecommune ()
dim ws1, ws2 as worksheets
dim searchrng as range
set ws1 = sheets("Data")
set ws2 = sheets("CleCommunes")
set searchrng = ws1.range("B2:B75000")

for each c in searchrng

if isempty(c) then

c.value = worksheet.function.index(ws2.range("A2:A6220", worksheet.function.match(ws1.range("A2:A75000"), ws2.range("A2:A6220"),0))

end if

next

end sub

en sachant que j’utilise des tableaux nommés « Data » et « Cléscommunes » mais par contre je ne parviens pas à les utiliser.

PS: désolé je suis sur mobile je n’ai pas de fichier test je vous en envoie un des que possible!

merci beaucoup par avance pour votre aide!!

rk

 

[Staple1600]

Bonsoir le fil

Ceci n'est pas une syntaxe VBA valide
worksheet.function.index
Et subséquemment, celle-ci non plus
worksheet.function.match


Le temps d'ouvrir Excel et je reviens avec la bonne syntaxe.

 

[Staple1600]

Re


Test OK sur mon fichier exemple

Sub recherchecommune_bis()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim searchrng As Range, c As Range
Set ws1 = Sheets("Data"): Set ws2 = Sheets("Cle")
With Application
    .ScreenUpdating = False
    Set searchrng = ws1.Range("A2:A10")
    For Each c In searchrng
    If Not IsEmpty(c) Then
    c.Offset(, 1).Value = .Index(ws2.Range("B2:B10"), .Match(c, ws2.Range("A2:A10"), 0))
    End If
    Next
End With
End Sub

NB: Adapter les plages et le noms des feuilles selon les conditions réelles.
(Ici pour le test , j'ai utilisé A2:A10)

 

[r3dkross]

Re


Test OK sur mon fichier exemple

Sub recherchecommune_bis()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim searchrng As Range, c As Range
Set ws1 = Sheets("Data"): Set ws2 = Sheets("Cle")
With Application
    .ScreenUpdating = False
    Set searchrng = ws1.Range("A2:A10")
    For Each c In searchrng
    If Not IsEmpty(c) Then
    c.Offset(, 1).Value = .Index(ws2.Range("B2:B10"), .Match(c, ws2.Range("A2:A10"), 0))
    End If
    Next
End With
End Sub

NB: Adapter les plages et le noms des feuilles selon les conditions réelles.
(Ici pour le test , j'ai utilisé A2:A10)

Quelle rapidité!! Merci beaucoup je test ça dès que possible!!

J’ignorais qu’il n’était pas indispensable de déclarer la ligne de l’offset, ni même l’appel des fonctions de cette manière (je ne connais finalement pas grand chose^^), c’est très instructif merci beaucoup!!

 

[r3dkross]

Sans surprise tout fonctionne merci !!

J'ai ajouté la fonction gauche en cas d'erreur pour convenir à mon besoin, je mets le code complet ici:

Sub recherchecommune()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Data"): Set ws2 = Sheets("FullCle")
Dim searchrng As Range, c As Range
Dim indexdernligne As Long, matchdernligne As Long
indexdernligne = Sheets("FullCle").Range("A" & Rows.Count).End(xlUp).Row
matchdernligne = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Dim searchCle As String
Dim aCell As Range
Dim clecolletter As Variant

    searchCle = "Clé" 'on déclare les variables de recherche

    'après on paramètre les champs de recherche:
    Set aCell = Worksheets("Data").Rows(1).Find(What:=searchCle, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
clecolletter = ToColletter(aCell.Column)

With Application
 .ScreenUpdating = False
 Set searchrng = ws1.Range(clecolletter & "2:" & clecolletter & matchdernligne)
 For Each c In searchrng
 If Not IsEmpty(c) Then

 c.Offset(, 1).Value = Application.IfError((.Index(ws2.Range("F2:F" & indexdernligne), .Match(c, ws2.Range("A2:A" & indexdernligne), 0))), .Index(ws2.Range("F2:F" & indexdernligne), .Match(Left(c, 5), ws2.Range("A2:A" & indexdernligne), 0)))
 End If
 
 Next
End With
End Sub

J'imagine que mon code peut être optimisé car ça prend environ 50s pour traiter 75000 lignes mais au moins une fois que c'est fait le classeur n'est plus ralenti!!

Merci encore!!

 

[Staple1600]

Bonsoir le fil

Essaie ce code (adapté d'un code de JB)

Sub ChercheCommunes()
Dim f1 As Worksheet: Set f1 = Feuil1
Dim f2 As Worksheet: Set f2 = Feuil2
Dim vBase, c As Range
Set dico = CreateObject("scripting.dictionary")
vBase = f2.Range(f2.[A2], f2.Cells(Rows.Count, 2).End(3)).Value
Application.ScreenUpdating = False
For i = 2 To UBound(vBase, 1)
dico(vBase(i - 1, 1)) = i
Next i
For Each c In f1.Range(f1.[A2], f1.Cells(Rows.Count, 1).End(3))
clé = c: lg = dico(clé)
c.Offset(, 1) = vBase(lg, 2)
Next
End Sub

NB: Test OK sur mon fichier de test.

 

[r3dkross]

Bonsoir le fil

Essaie ce code (adapté d'un code de JB)

Sub ChercheCommunes()
Dim f1 As Worksheet: Set f1 = Feuil1
Dim f2 As Worksheet: Set f2 = Feuil2
Dim vBase, c As Range
Set dico = CreateObject("scripting.dictionary")
vBase = f2.Range(f2.[A2], f2.Cells(Rows.Count, 2).End(3)).Value
Application.ScreenUpdating = False
For i = 2 To UBound(vBase, 1)
dico(vBase(i - 1, 1)) = i
Next i
For Each c In f1.Range(f1.[A2], f1.Cells(Rows.Count, 1).End(3))
clé = c: lg = dico(clé)
c.Offset(, 1) = vBase(lg, 2)
Next
End Sub

NB: Test OK sur mon fichier de test.

Merci beaucoup pour cette proposition ! Par contre je n'arrive pas à l'adapter à mon fichier, j'obtiens une erreur 9, l'indice n'appartient pas à la sélection sur cette partie du code :

c.Offset(, 1) = vBase(lg, 2)

Une particularité à signaler qui a toute son importance, l'emplacement des colonnes Data peut varier c'est pour cela que je fais une recherche de la colonne "clé" afin de la localiser.
J'ai bien l'impression qu'il s'agisse de cette partie de code mais je n'en suis pas sûr:

clé = c: lg = dico(clé)

Enfin je me trompe peut être car j'ai du mal à déchiffrer le code mais je ne vois pas de recherche gauche avec 5 caractères sur la clé en cas d'erreur de recherche. C'est fondamental car les 3 derniers caractères de la clé peuvent être optionnels afin de déterminer la bonne commune.

J'avais vu que l'objet dictionnary était très rapide mais j'ai du mal à tout combiner! Merci beaucoup pour ton aide en tout cas!

 

[r3dkross]

J'aurais du le faire dès le début mais voici un fichier exemple de mes données. (désolé du spam :/)

Merci encore!

 

[Staple1600]

Bonsoir

1)

La position des colonnes Jour A & Jour B & Clé sont aléatoires.

Pourquoi ?

2) Personnellement, j'agencerais mes données autrement.
1 seule feuille qui fait office de base de données.

Bref, je me simplifierai la tâche en amont

 

[r3dkross]

Bonsoir

1)

Pourquoi ?

2) Personnellement, j'agencerais mes données autrement.
1 seule feuille qui fait office de base de données.

Bref, je me simplifierai la tâche en amont

Bonsoir Staple1600,

Les lignes qui viennent dans l’onglet data proviennnent d’extractions réalisées à la carte par les utilisateurs sur un autre outil. Du coup ils sélectionnent les champs qu’ils souhaitent faisant varier la position des colonnes.

J’ai pu parvenir à mes fins grâce à la piste du dictionnaire que tu m’as fait parvenir précédemment, merci beaucoup!

J’ai pu réduire ainsi le temps de traitement complet (import d’un fichier de 200000 lignes avec 5 colonnes calculées dont 3 en dictionnaire) en passant de 10mins à 2mins 30.
Je sais que c’est encore long mais ça progresse

Je posterais mon code prochainement, il est évident qu’il peut être optimisé. Ma prochaine piste concerne l’import en lui même, je réalise un:

workbook1.sheetname.cells.copy
workbook2.sheetname2.paste special

(La syntaxe n’est pas bonne je suis sur mobile désolé)
J’ai lu que le range to range était plus rapide pour les gros volumes de données, j’essayerais de l’adapter sur mon code.

En tout cas merci beaucoup encore une fois!!

 

[Staple1600]

Re

Il y a plus rapide passer par un tableau (Array)
Exemple

Sub test()
Dim a
a = Feuil1.Cells(1).CurrentRegion.Value
Feuil2.Cells(1).Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

 

[r3dkross]

Re

Il y a plus rapide passer par un tableau (Array)
Exemple

Sub test()
Dim a
a = Feuil1.Cells(1).CurrentRegion.Value
Feuil2.Cells(1).Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Bonjour,

Je n'ai pas réussi à faire fonctionner le code cependant j'ai cherché cette piste et j'ai pu réussi à faire descendre le temps de copie à environ 15ecs!! Merci!! Voici le code que j'utilise:

Sub Import_Stock()

Dim WS As Worksheet
Dim wb2 As Workbook
Dim vFile As Variant
Dim shAry As Variant
Dim sh As Variant

Set WS = ActiveWorkbook.Worksheets("Data")

'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(vFile)
WS.Cells.ClearContents
With wb2
    shAry = Array(.Sheets(1))
End With
For Each sh In shAry
    Dim LastCell As Range
    Set LastCell = WS.Range("A:O").Find(What:="*", SearchDirection:=xlPrevious)
    If LastCell Is Nothing Then Set LastCell = WS.Range("A1")
    Range(sh.Cells(1, 1), sh.Cells.SpecialCells(xlCellTypeLastCell)).Copy
    WS.Cells(LastCell.Row, 1).PasteSpecial xlPasteValues
Next

et ça c'est mon code pour les différents calculs comme le dictionnaire.
J'imagine que je dois pouvoir l'initialiser une fois avec un offset mais bon ça marche pour le moment!
En revanche je sais que je peux gagner du temps ici car le dictionnaire est rempli de valeurs nulles dans la dernière partie.

Sub FormulesClé()
Dim dernligne As Long
Dim DernCol As Integer
DernCol = Sheets("Data").Cells(1, Cells.Columns.Count).End(xlToLeft).Column ' on cherche la dernière colonne de la feuille data
dernligne = Range("A" & Rows.Count).End(xlUp).Row 'on cherche le numéro de la dernière ligne de la colonne A
Dim derncolletter, jourphotocolletter As Variant
derncolletter = ToColletter(DernCol) 'récupération de la lettre de la dernière colonne grâce à la fonction tocolletter
Dim Dic As Object
Dim clecolletter As Variant
Dim searchBase, searchCentre, searchZone, searchCle, searchJourPhoto, searchDateinitiale As String
Dim Cl, acell, bcell, ccell, dcell, ecell As Range



    
    searchBase = "******"                    'on déclare les variables de recherche
    searchCentre = "******"                    '
    searchZone = "******"                        '
    searchCle = "Clé"                          '
    searchJourPhoto = "Jour Photo"             '
    searchDateinitiale = "Date Cible***" '
    
    'après on paramètre les champs de recherche:
    Set CelluleCle = Worksheets("Data").Rows(1).Find(What:=searchCle, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    Set acell = Worksheets("Data").Rows(1).Find(What:=searchBase, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    Set bcell = Worksheets("Data").Rows(1).Find(What:=searchCentre, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    Set ccell = Worksheets("Data").Rows(1).Find(What:=searchZone, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    Set dcell = Worksheets("Data").Rows(1).Find(What:=searchJourPhoto, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    Set ecell = Worksheets("Data").Rows(1).Find(What:=searchDateinitiale, LookIn:=xlValues, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
clecolletter = ToColletter(CelluleCle.Column) ' identification de la lettre de colonne "Clé"

Dim srchRn As Range, c As Range
Set srchRn = Range(clecolletter & "2:" & clecolletter & dernligne) 'recherche dans la colonne "Clé"

For Each c In srchRn
    If IsEmpty(c) Then
    'ici pour faire la clé on concatène et le numéro de colonne de l'offset est obtenu grâce à la différence des numéros de colonne
    c.Value = c.Offset(0, acell.Column - c.Column).Value & c.Offset(0, bcell.Column - c.Column).Value & c.Offset(0, ccell.Column - c.Column).Value
    
    End If
Next
''''recherche les communes en créant un dictionnaire de FullCle''''''''''''
Set Dic = CreateObject("scripting.dictionary") 'nom du dico

With Sheets("FullCle") 'avec la feuille FullCle
For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) ' pour chacune des cellules de la colonne A
Dic(Cl.Value) = Cl.Offset(, 5).Value 'clé du dico = colonne A et item = valeur colonne en décalé de 5 sur la droite
Next Cl ' prochaine cellule dans la même colonne
End With
With Sheets("Data") ' avec la feuille Data maintenant
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp)) 'le champ de recherche est positionné sur la colonne "clé"
If Dic.exists(Cl.Value) Then Cl.Offset(, 1).Value = Dic(Cl.Value) 'si la valeur de la clé Data est dans le dico alors la case de droite obtiendra la valeur item du dico soit ici la commune

Next Cl
End With
With Sheets("Data") 'même opération mais cette fois ci avec les 5 premoiers caractères de gauche
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp))
If Dic.exists(Left(Cl.Value, 5)) Then Cl.Offset(, 1).Value = Dic(Left(Cl.Value, 5))

Next Cl
End With
Set Dic = Nothing 'reset du Dico
''''''''''''''''''''''''''''recherche les CA''''''''''''''''''''''''''''
Set Dic = CreateObject("scripting.dictionary")

With Sheets("FullCle")
For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Dic(Cl.Value) = Cl.Offset(, 6).Value
Next Cl
End With
With Sheets("Data")
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp))
If Dic.exists(Cl.Value) Then Cl.Offset(, 2).Value = Dic(Cl.Value)

Next Cl
End With
With Sheets("Data")
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp))
If Dic.exists(Left(Cl.Value, 5)) Then Cl.Offset(, 2).Value = Dic(Left(Cl.Value, 5))

Next Cl
End With
Set Dic = Nothing
'''''''''''''''''''recherche zone renfort''''''''''''''''''''
Set Dic = CreateObject("scripting.dictionary")

With Sheets("FullCle")

For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Dic(Cl.Value) = Cl.Offset(, 7).Value
Next Cl
End With
With Sheets("Data")
Application.ScreenUpdating = False
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp))
If Dic.exists(Cl.Value) Then Cl.Offset(, 3).Value = Dic(Cl.Value)

Next Cl
End With
With Sheets("Data")
For Each Cl In .Range(clecolletter & "2", .Range(clecolletter & Rows.Count).End(xlUp))
If Dic.exists(Left(Cl.Value, 5)) Then Cl.Offset(, 3).Value = Dic(Left(Cl.Value, 5))

Next Cl

End With
Set Dic = Nothing
''''''''''''''''''''''''''''''calcul du retard'''''''''''''''''''''''
jourphotocolletter = ToColletter(dcell.Column) 'localisation de la colonne jourphoto

With Application
 .ScreenUpdating = False

 For Each c In .Range(jourphotocolletter & "2", .Range(jourphotocolletter & Rows.Count).End(xlUp))
 On Error Resume Next
 If DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) > 90 Then

 c.Offset(, DernCol - dcell.Column).Value = "+ 90 jours"
 
 ElseIf DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) < 8 Then
 
  c.Offset(, DernCol - dcell.Column).Value = "- 7 Jours"
ElseIf DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) > 7 And DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) < 15 Then
  c.Offset(, DernCol - dcell.Column).Value = "1 à 14 Jours"
  ElseIf DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) > 14 And DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) < 31 Then
  c.Offset(, DernCol - dcell.Column).Value = "15 à 30 Jours"
  ElseIf DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) > 30 And DateDiff("d", c.Offset(, ecell.Column - dcell.Column), c) < 91 Then
  c.Offset(, DernCol - dcell.Column).Value = "1 à 3 Mois"
  Else
  c.Offset(, DernCol - dcell.Column).Value = "à venir"
 End If
 
 Next
 
End With
Sheets("Dashboard").Activate
End Sub

Bref en tout cas je suis descendu à 50 secondes ce qui est déjà très satisfaisant!!
Merci beaucoup Staple1600!!

 

[Staple1600]

Bonsoir le fil,

[Note pour plus tard]
Cela peut être utile ou intéressant pour les lecteurs du fil de citer les sources des codes utilisés
=>source<=
[/Note pour plus tard]

Pendant que tu étais sur une piste, je créais ce petit exemple pour que tu puisses tester comme je l'ai fait.

Sub test()
Dim col1(), t(), arBase, arVille(), arCle(), i&
Dim f1 As Worksheet: Set f1 = Feuil1
Dim f2 As Worksheet: Set f2 = Feuil2
col1 = f1.Range(f1.[A2], f1.Cells(Rows.Count, 1).End(3)).Value2
arBase = f2.Range(f2.[A2], f2.Cells(Rows.Count, 2).End(3)).Value
With Application
    .ScreenUpdating = False
    arCle = .Index(arBase, 0, 1)
    ReDim t(1 To UBound(col1, 1))
    For i = LBound(col1) To UBound(col1)
    t(i) = .Index(arBase, .Match(col1(i, 1), arCle, 0), 2)
    Next
    f1.[B2].Resize(UBound(t, 1)).Value = .Transpose(t)
End With
End Sub

Sub Creer_Test()
Feuil2.Name = "BASE"
Feuil2.Range("A2:B31") = Array("=ROW()+99", "=""VILLE""&ROW()-1")
Feuil2.[A1:B1] = Array("CLE", "VILLES")
Feuil2.UsedRange = Feuil2.UsedRange.Value
Feuil1.[A1:B1] = Array("CLE", "VILLES")
Feuil1.Range("A2:A31") = "=RANDBETWEEN(101,131)"
Feuil1.UsedRange = Feuil1.UsedRange.Value
End Sub

NB: Ne lancer qu'un seule fois, la macro Créer_Test

 

[Staple1600]

Re

Sinon en mémoire du petit garçon de 4 que je fus
"Dis, pourquoi !"

Sub WhatTheFuck()
Dim shAry, sh
With ActiveWorkbook
    shAry = Array(.Sheets(1))
End With
For Each sh In shAry
MsgBox sh.Cells(1).Parent.Name
Next
End Sub
Sub Maybe_It_is_Enough(Optional EnfinJeDisCela_Je_dis_rien)
MsgBox ActiveWorkbook.Sheets(1).Cells(1).Parent.Name
End Sub

 

[r3dkross]

Je suis démasqué pour le code
J’ai tellement arpenté de sites que je n’arrive parfois plus à retrouver là où je suis passé, mais je prends bien en compte ta note pour la prochaine fois!!

merci encore pour ton aide et ce code que je testerais à tête reposée, et tout particulièrement le dernier qui m’interpelle quand je le lis!!

très bonne soirée!