Kael_88
XLDnaute Occasionnel
Le forum,
Bonjour, prenant en compte votre savoir, je me suis fait se petit code qui fonctionne, d'où ma question :
y a t il moyen de le simplifier avec un traitement des donnée rapide ?
PS: les feuilles sont d'environ 50000 lignes et 22 colonnes
En attente de vos conseilles.
Cordialement
Bonjour, prenant en compte votre savoir, je me suis fait se petit code qui fonctionne, d'où ma question :
y a t il moyen de le simplifier avec un traitement des donnée rapide ?
PS: les feuilles sont d'environ 50000 lignes et 22 colonnes
VB:
Sub Import_A_D_E_F()
Dim t, Maa, Saa, Kaa, d1 As Object, d2 As Object, i&, x$, y$, z$
Dim WsMaa As Worksheet, WsSaa As Worksheet, WsKaa As Worksheet, WsMSK As Worksheet, WsSyE As Worksheet
Dim rng As Range, derl As Long
Set rng = Range("B2", Range("B50000").End(xlUp)) '.Select
derl = rng.Rows.Count + 1
Set WsMaa = Sheets("Data Maa") 'Feuil source Maa
Set WsSaa = Sheets("Data Saa") 'Feuil source Saa
Set WsKaa = Sheets("Data Kaa") 'Feuil source Kaa
Set WsMSK = Sheets("Synthèse Maa & Saa & Kaa") 'Feuil destination
Set WsSyE = Sheets("Synthèse Erreur") 'Feuil destination
Maa = WsMaa.[A1].CurrentRegion.Resize(, 22)
Saa = WsSaa.[A1].CurrentRegion.Resize(, 15)
Kaa = WsKaa.[A1].CurrentRegion.Resize(, 15)
SyE = WsSyE.[A1].CurrentRegion.Resize(, 15)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
Set d5 = CreateObject("Scripting.Dictionary")
Set d6 = CreateObject("Scripting.Dictionary")
WsMSK.Range("D2:Z" & derl).ClearContents 'Suppression valeur du tableau
WsMSK.Range("A2:A" & derl).ClearContents 'Suppression valeur du tableau
For i = 2 To UBound(SyE)
y = SyE(i, 2)
x = SyE(i, 7)
z = SyE(i, 8)
If x <> "" Then
If d6.exists(y) Then
d6(y) = d6(y) & Chr(10) & x
Else
d6(y) = x
End If
End If
If z <> "" Then
If d5.exists(y) Then
d5(y) = d5(y) & Chr(10) & z
Else
d5(y) = z
End If
End If
Next
For i = 2 To UBound(Kaa)
y = Kaa(i, 8)
x = Kaa(i, 10)
If x <> "" And x <> "0" Then
If d4.exists(y) Then
d4(y) = d4(y) & Chr(10) & x
Else
d4(y) = x
End If
End If
Next
For i = 2 To UBound(Saa)
y = Saa(i, 1)
x = Saa(i, 4)
If x <> "" And x <> "0" Then
If d3.exists(y) Then
d3(y) = d3(y) & Chr(10) & x
Else
d3(y) = x
End If
End If
Next
For i = 2 To UBound(Maa)
x = Maa(i, 5)
y = Maa(i, 6)
z = Maa(i, 14)
If x <> "" Then
If d1.exists(y) Then
d1(y) = d1(y) & Chr(10) & x
Else
d1(y) = x
End If
End If
If z <> "" Then
If d2.exists(y) Then
d2(y) = d2(y) & Chr(10) & z
Else
d2(y) = z
End If
End If
Next
With WsMSK.[A1].CurrentRegion.Resize(, 9)
t = .Value
For i = 2 To UBound(t)
t(i, 1) = d1(t(i, 2))
t(i, 4) = d2(t(i, 2))
t(i, 5) = d3(t(i, 2))
t(i, 6) = d4(t(i, 2))
t(i, 7) = d6(t(i, 2))
t(i, 8) = d5(t(i, 2))
Next
If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
.Columns(1) = Application.Index(t, , 1)
.Columns(4) = Application.Index(t, , 4)
.Columns(5) = Application.Index(t, , 5)
.Columns(6) = Application.Index(t, , 6)
.Columns(7) = Application.Index(t, , 7)
.Columns(8) = Application.Index(t, , 8)
.Columns(9) = Application.Index(t, , 9)
End With
For i = 2 To derl
If Cells(i, 4) <> "" Then
texte = "=" & Cells(i, 4)
Cells(i, 11) = Replace(texte, Chr(10), "+")
Else
Cells(i, 11) = ""
End If
If Cells(i, 5) <> "" Then
texte = "=" & Cells(i, 5)
Cells(i, 12) = Replace(texte, Chr(10), "+")
Else
Cells(i, 12) = ""
End If
If Cells(i, 6) <> "" Then
texte = "=" & Cells(i, 6)
Cells(i, 13) = Replace(texte, Chr(10), "+")
Else
Cells(i, 13) = ""
End If
If Cells(i, 11) <> Cells(i, 12) Then 'Or Cells(i, 11) <> Cells(i, 13) Then
Cells(i, 9) = "Ecart"
Else
Cells(i, 9) = ""
End If
Next i
'Columns("A:z").AutoFit
Range("A1:M1").Interior.ColorIndex = "6"
Range("A:A").ColumnWidth = 12
Range("B:B").ColumnWidth = 15
Range("C:C").ColumnWidth = 40
Range("D:G").ColumnWidth = 12
Range("H:H").ColumnWidth = 80
Range("I:M").ColumnWidth = 12
Range("A1") = "Location"
Range("B1") = "Materiel"
Range("C1") = "Description"
Range("D1").FormulaR1C1 = "=""Qté Maa :""&COUNTA(R[1]C:R[9999]C)"
Range("E1").FormulaR1C1 = "=""Qté Saa : ""&COUNTA(R[1]C:R[9999]C)"
Range("F1").FormulaR1C1 = "=""Qté Kaa : ""&COUNTA(R[1]C:R[9999]C)"
Range("G1") = "Qté Réel"
Range("H1") = "Commentaire"
Range("I1") = "Différence"
Range("J1") = " "
Range("K1") = "Total" & Chr(10) & "Maa"
Range("L1") = "Total" & Chr(10) & "Saa"
Range("M1") = "Total" & Chr(10) & "Kaa"
With Range("A1:Z" & derl)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
With Range("A2:C" & derl)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
End With
Range("A2").Select
End SubCordialement
Dernière édition:
