Erroné je diraisBonjour
>La phrase "Proche des tableaux, l'objet dictionnaire peut aussi être utile dans certains cas. Il s'agit d'un tableau à deux colonnes...
Consternant!
BISSON
Bonjour
" l'objet dictionnaire peut aussi être utile dans certains cas. Il s'agit d'un tableau à deux colonnes..."
Consternant!
BISSON
Bonjour à tous,
Cisco : voir le #20. A++
A+ à tous
Sub essaiLaurent950_Test778suite()
Dim TI As Single
TI = Timer
Dim d As New Scripting.Dictionary
d.CompareMode = TextCompare
Dim Tb() As Variant
Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim x As Variant
' ****************************************************************************************************
For i = LBound(Tb) + 1 To UBound(Tb)
If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
x = d(Tb(i, 2) & "|" & Tb(i, 3))
d(Tb(i, 2) & "|" & Tb(i, 3)) = Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(x(3), 16) + Tb(i, 16), x(3))
Else
cpt = d.Count + 1
d.Add Tb(i, 2) & "|" & Tb(i, 3), Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16), cpt + 1)
End If
Next i
' ****************************************************************************************************
[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub essaiLaurent950_Test77Bis()
Dim TI As Single
TI = Timer
Dim d As New Scripting.Dictionary
Set d = New Dictionary
d.CompareMode = TextCompare
Dim NumItem As New Scripting.Dictionary
Set NumItem = New Dictionary
Dim Tb() As Variant
Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
' ****************************************************************************************************
Dim Ar As Variant
Dim x As Variant
For i = LBound(Tb) + 1 To UBound(Tb)
If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
cpt = NumItem(Tb(i, 2) & "|" & Tb(i, 3))
d(Tb(i, 2) & "|" & Tb(i, 3)) = Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16) + Tb(i, 16))
Else
cpt = d.Count + 1
NumItem(Tb(i, 2) & "|" & Tb(i, 3)) = cpt
d.Add Tb(i, 2) & "|" & Tb(i, 3), Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16))
End If
Next i
' ****************************************************************************************************
[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub essaiLaurent950_Test779suite()
Dim TI As Single
TI = Timer
Dim d As New Scripting.Dictionary
d.CompareMode = TextCompare
Dim Tb() As Variant
Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(1 To 4, 1 To 1)
' ****************************************************************************************************
For i = LBound(Tb) + 1 To UBound(Tb)
If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
cpt = d(Tb(i, 2) & "|" & Tb(i, 3))
TabRes(3, cpt) = TabRes(3, cpt) + Tb(i, 16)
Else
cpt = d.Count + 1
d.Add Tb(i, 2) & "|" & Tb(i, 3), cpt
TabRes(1, cpt) = Tb(i, 2)
TabRes(2, cpt) = Tb(i, 3)
TabRes(3, cpt) = Tb(i, 16)
TabRes(4, cpt) = cpt
ReDim Preserve TabRes(1 To 4, 1 To (cpt + 1))
End If
Next i
[v1].Resize(UBound(TabRes, 2), UBound(TabRes, 1)) = Application.Transpose(TabRes)
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub EssaiDranreb()
Dim TDon(), LDon As Long, TRés(), LRés As Long, Clé As String, Dic As New dictionary
TDon = ActiveSheet.[A1].CurrentRegion.Value
ReDim TRés(1 To UBound(TDon, 1), 1 To 3)
For LDon = 1 To UBound(TDon, 1)
Clé = TDon(LDon, 2) & "|" & TDon(LDon, 3)
If Dic.exists(Clé) Then
LRés = Dic(Clé)
TRés(LRés, 3) = TRés(LRés, 3) + TDon(LDon, 16)
Else
LRés = Dic.Count + 1: Dic(Clé) = LRés
TRés(LRés, 1) = TDon(LDon, 2)
TRés(LRés, 2) = TDon(LDon, 3)
TRés(LRés, 3) = TDon(LDon, 16)
End If
Next LDon
ActiveSheet.[V1].Resize(Dic.Count, 3) = TRés
End Sub
Code
Sub essaiLaurent950_Test780suite()
Dim Ti As Single
Ti = Timer
Dim d As New Scripting.Dictionary
d.CompareMode = TextCompare
Dim Tb() As Variant
Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(LBound(Tb) To UBound(Tb), 1 To 3)
' ****************************************************************************************************
For i = LBound(Tb) + 1 To UBound(Tb)
If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
cpt = d(Tb(i, 2) & "|" & Tb(i, 3))
TabRes(cpt, 3) = TabRes(cpt, 3) + Tb(i, 16)
Else
cpt = d.Count + 1
d.Add Tb(i, 2) & "|" & Tb(i, 3), cpt
TabRes(cpt, 1) = Tb(i, 2)
TabRes(cpt, 2) = Tb(i, 3)
TabRes(cpt, 3) = Tb(i, 16)
End If
Next i
' ****************************************************************************************************
'[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK
[V1].Resize(UBound(TabRes, 1), 3) = TabRes
MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub
Option Explicit
Sub essaiLaurent950()
Dim TI As Single: TI = Timer
Dim d As New Scripting.Dictionary
d.CompareMode = TextCompare
Dim Clef As String
Dim Tb() As Variant
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(1 To 5, 1 To 1)
' ****************************************************************************************************
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) = LCase("FEUILLE1") Or _
LCase(ws.Name) = LCase("FEUILLE2") Or _
LCase(ws.Name) = LCase("FEUILLE3") Then
Tb = ws.Range("a1").CurrentRegion
' ****************************************************************************************************
For i = LBound(Tb) + 1 To UBound(Tb)
Clef = Tb(i, 1) & "|" & Tb(i, 1)
If d.Exists(Clef) Then
cpt = d(Clef)
TabRes(3, cpt) = TabRes(3, cpt) + Tb(i, 5)
TabRes(4, cpt) = TabRes(4, cpt) + Tb(i, 6)
TabRes(5, cpt) = TabRes(5, cpt) + 1
Else
cpt = d.Count + 1
d.Add Clef, cpt
TabRes(1, cpt) = Tb(i, 1)
TabRes(2, cpt) = Tb(i, 2)
TabRes(3, cpt) = Tb(i, 5)
TabRes(4, cpt) = Tb(i, 6)
TabRes(5, cpt) = 1
ReDim Preserve TabRes(1 To 5, 1 To (cpt + 1))
End If
Next i
End If
' ****************************************************************************************************
Next ws
[a2].Resize(UBound(TabRes, 2), UBound(TabRes, 1)) = Application.Transpose(TabRes)
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function
Sub DicoTriTransfertLaurent950()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
' TI = Timer
' ***************************************************
'Dim d As New Scripting.Dictionary
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = TextCompare
Dim cef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
Set ShF1 = Worksheets("BDD")
Tb = ShF1.Range(ShF1.Cells(2, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, j, cpt As Double
' ***************************************************
Dim tabDico() As Variant
ReDim tabDico(0)
Dim TabRes() As Variant
ReDim TabRes(1 To 8, 1 To 1)
Dim Temp() As Variant
' ***************************************************
Dim a() As Variant
' ***************************************************
Dim ShF2 As Worksheet
Set ShF2 = Worksheets("TrieparIGC")
'ShF2.Range(ShF2.Cells(2, 5), ShF2.Cells(ShF2.Cells(65536, 5).End(xlUp).Row + 1, 30)).Interior.Pattern = xlNone
'ShF2.Range(ShF2.Cells(2, 5), ShF2.Cells(ShF2.Cells(65536, 5).End(xlUp).Row + 1, 30)).ClearContents
' ***************************************************
For i = LBound(Tb) + 1 To UBound(Tb) ' Commence à la ligne 2 (LBound(Tb) + 1)
clef = Tb(i, 12)
If d.Exists(clef) Then
cpt = d(clef)
Temp = tabDico(cpt - 1)
ReDim Preserve Temp(1 To 8, 1 To UBound(Temp, 2) + 1)
tabDico(cpt - 1) = Temp
tabDico(cpt - 1)(1, UBound(Temp, 2)) = Tb(i, 4)
tabDico(cpt - 1)(2, UBound(Temp, 2)) = Tb(i, 5)
tabDico(cpt - 1)(3, UBound(Temp, 2)) = Tb(i, 6)
tabDico(cpt - 1)(4, UBound(Temp, 2)) = Tb(i, 18)
tabDico(cpt - 1)(5, UBound(Temp, 2)) = CDbl(Tb(i, 19))
tabDico(cpt - 1)(6, UBound(Temp, 2)) = Tb(i, 12)
tabDico(cpt - 1)(7, UBound(Temp, 2)) = Tb(i, 112)
tabDico(cpt - 1)(8, UBound(Temp, 2)) = Tb(i, 95)
Erase Temp
Else
cpt = d.Count + 1
d(clef) = cpt
tabDico(cpt - 1) = TabRes
tabDico(cpt - 1)(1, 1) = Tb(i, 4)
tabDico(cpt - 1)(2, 1) = Tb(i, 5)
tabDico(cpt - 1)(3, 1) = Tb(i, 6)
tabDico(cpt - 1)(4, 1) = Tb(i, 18)
tabDico(cpt - 1)(5, 1) = CDbl(Tb(i, 19))
tabDico(cpt - 1)(6, 1) = Tb(i, 12)
tabDico(cpt - 1)(7, 1) = Tb(i, 112)
tabDico(cpt - 1)(8, 1) = Tb(i, 95)
ReDim Preserve tabDico((cpt - 1) + 1)
End If
Next i
' Suppression de la derniere dimension
ReDim Preserve tabDico(UBound(tabDico) - 1)
' Boucle sur tabDico
cpt = 4
For i = LBound(tabDico) To UBound(tabDico)
' Tri des tableaux
a = Application.Transpose(tabDico(i))
If NumberOfArrayDimensions(a) = 2 Then
Tri a, 5, LBound(a, 1), UBound(a, 1)
tabDico(i) = Application.Transpose(a)
End If
Erase a
For j = 1 To 7
ShF2.Cells(cpt, j + 1).Resize(UBound(tabDico(i), 2), 1) = Application.Index(Application.Transpose(tabDico(i)), , j)
Next j
ShF2.Cells(cpt, 12).Resize(UBound(tabDico(i), 2), 1) = Application.Index(Application.Transpose(tabDico(i)), , 8)
cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 1
Next i
'MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2, ColTri)
g = gauc: d = droi
Do
Do While a(g, ColTri) < ref: g = g + 1: Loop
Do While ref < a(d, ColTri): d = d - 1: Loop
If g <= d Then
For k = LBound(a, 2) To UBound(a, 2)
Temp = a(g, k): a(g, k) = a(d, k): a(d, k) = Temp
Next k
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, ColTri, g, droi)
If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub
Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function
Sub DicoTriTransfertLaurent950_Bis()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
TI = Timer
' ***************************************************
Dim cef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
Set ShF1 = Worksheets("BDD")
Tb = ShF1.Range(ShF1.Cells(3, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, cptFr, cptAutr As Double
cptFr = 1: cptAutr = 1
' ***************************************************
Dim TabResFr() As Variant
ReDim TabResFr(1 To 8, 1 To 1)
Dim TabResAutr() As Variant
ReDim TabResAutr(1 To 8, 1 To 1)
' ***************************************************
Dim ShF2 As Worksheet
Set ShF2 = Worksheets("TrieparIGC")
ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).Interior.Pattern = xlNone
ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).ClearContents
' ***************************************************
' Format
Dim RgnFormat(0 To 0, 0 To 1) As Range
Set RgnFormat(0, 0) = ShF1.Range(ShF1.Cells(3, 95), ShF1.Cells(3, 95))
' ***************************************************
For i = LBound(Tb, 1) To UBound(Tb, 1)
Clef = Tb(i, 12)
If Clef = "France" Then
TabResFr(1, cptFr) = Tb(i, 4)
TabResFr(2, cptFr) = Tb(i, 5)
TabResFr(3, cptFr) = Tb(i, 6)
TabResFr(4, cptFr) = Tb(i, 18)
TabResFr(5, cptFr) = CDbl(Tb(i, 19))
TabResFr(6, cptFr) = Tb(i, 12)
TabResFr(7, cptFr) = Tb(i, 112)
TabResFr(8, cptFr) = Tb(i, 95)
cptFr = cptFr + 1
ReDim Preserve TabResFr(1 To 8, 1 To cptFr)
Else
TabResAutr(1, cptAutr) = Tb(i, 4)
TabResAutr(2, cptAutr) = Tb(i, 5)
TabResAutr(3, cptAutr) = Tb(i, 6)
TabResAutr(4, cptAutr) = Tb(i, 18)
TabResAutr(5, cptAutr) = CDbl(Tb(i, 19))
TabResAutr(6, cptAutr) = Tb(i, 12)
TabResAutr(7, cptAutr) = Tb(i, 112)
TabResAutr(8, cptAutr) = Tb(i, 95)
cptAutr = cptAutr + 1
ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr)
End If
Next i
' Suppression d'une dimension
ReDim Preserve TabResFr(1 To 8, 1 To cptFr - 1)
ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr - 1)
' Tri des tableaux
TabResFr = Application.Transpose(TabResFr)
TabResAutr = Application.Transpose(TabResAutr)
' Test dimension Variable tableau
If NumberOfArrayDimensions(TabResFr) = 2 Then
Tri TabResFr, 5, LBound(TabResFr, 1), UBound(TabResFr, 1)
TabResFr = Application.Transpose(TabResFr)
End If
If NumberOfArrayDimensions(TabResAutr) = 2 Then
Tri TabResAutr, 5, LBound(TabResAutr, 1), UBound(TabResAutr, 1)
TabResAutr = Application.Transpose(TabResAutr)
End If
' Transfert tableaux TabResFr
Cpt = 4
For i = 1 To 7
ShF2.Cells(Cpt, i + 1).Resize(UBound(TabResFr, 2), 1) = Application.Index(Application.Transpose(TabResFr), , i)
Next i
ShF2.Cells(Cpt, 12).Resize(UBound(TabResFr, 2), 1) = Application.Index(Application.Transpose(TabResFr), , 8)
Cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 3
' Transfert tableaux TabResAutr
For i = 1 To 7
ShF2.Cells(Cpt, i + 1).Resize(UBound(TabResAutr, 2), 1) = Application.Index(Application.Transpose(TabResAutr), , i)
Next i
ShF2.Cells(Cpt, 12).Resize(UBound(TabResAutr, 2), 1) = Application.Index(Application.Transpose(TabResAutr), , 8)
Cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 1
' ***************************************************
' Format
Set RgnFormat(0, 1) = ShF2.Range(ShF2.Cells(4, 12), ShF2.Cells(ShF2.Cells(65536, 2).End(xlUp).Row, 12))
RgnFormat(0, 0).Copy
RgnFormat(0, 1).PasteSpecial Paste:=xlPasteFormats
' ***************************************************
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2, ColTri)
g = gauc: d = droi
Do
Do While a(g, ColTri) < ref: g = g + 1: Loop
Do While ref < a(d, ColTri): d = d - 1: Loop
If g <= d Then
For k = LBound(a, 2) To UBound(a, 2)
temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
Next k
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, ColTri, g, droi)
If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub
Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function
Option Explicit
Sub DicoTriTransfertLaurent950_ter()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
TI = Timer
' ***************************************************
Dim Clef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
Set ShF1 = Worksheets("BDD")
Tb = ShF1.Range(ShF1.Cells(3, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, cptFr, cptAutr, Cpt, ResizCol As Double
cptFr = 1: cptAutr = 1
' ***************************************************
Dim TabResFr() As Variant
ReDim TabResFr(1 To 8, 1 To 1)
Dim TabResAutr() As Variant
ReDim TabResAutr(1 To 8, 1 To 1)
' ***************************************************
Dim ShF2 As Worksheet
Set ShF2 = Worksheets("TrieparIGC")
ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).Interior.Pattern = xlNone
ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).ClearContents
' ***************************************************
' Format
Dim RgnFormat(0 To 0, 0 To 1) As Range
Set RgnFormat(0, 0) = ShF1.Range(ShF1.Cells(3, 95), ShF1.Cells(3, 95))
' ***************************************************
For i = LBound(Tb, 1) To UBound(Tb, 1)
Clef = Tb(i, 12)
If Clef = "France" Then
TabResFr(1, cptFr) = Tb(i, 4)
TabResFr(2, cptFr) = Tb(i, 5)
TabResFr(3, cptFr) = Tb(i, 6)
TabResFr(4, cptFr) = Tb(i, 18)
TabResFr(5, cptFr) = CDbl(Tb(i, 19))
TabResFr(6, cptFr) = Tb(i, 12)
TabResFr(7, cptFr) = Tb(i, 112)
TabResFr(8, cptFr) = Tb(i, 95)
cptFr = cptFr + 1
ReDim Preserve TabResFr(1 To 8, 1 To cptFr)
Else
TabResAutr(1, cptAutr) = Tb(i, 4)
TabResAutr(2, cptAutr) = Tb(i, 5)
TabResAutr(3, cptAutr) = Tb(i, 6)
TabResAutr(4, cptAutr) = Tb(i, 18)
TabResAutr(5, cptAutr) = CDbl(Tb(i, 19))
TabResAutr(6, cptAutr) = Tb(i, 12)
TabResAutr(7, cptAutr) = Tb(i, 112)
TabResAutr(8, cptAutr) = Tb(i, 95)
cptAutr = cptAutr + 1
ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr)
End If
Next i
' Traitement des données
Cpt = Transfert(TabResFr(), 4, UBound(TabResFr, 2) - 1, ShF2)
Cpt = Transfert(TabResAutr, Cpt, UBound(TabResAutr, 2) - 1, ShF2)
' ***************************************************
' Format
Set RgnFormat(0, 1) = ShF2.Range(ShF2.Cells(4, 12), ShF2.Cells(ShF2.Cells(65536, 2).End(xlUp).Row, 12))
RgnFormat(0, 0).Copy
RgnFormat(0, 1).PasteSpecial Paste:=xlPasteFormats
' ***************************************************
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Function Transfert(ByRef a() As Variant, ByVal Cpt As Double, ByRef ResizCol As Double, ByRef ShF2 As Worksheet) As Double
Dim i As Double
' Suppression d'une dimension
ReDim Preserve a(1 To 8, 1 To ResizCol - 1)
' Tri des tableaux
a = Application.Transpose(a)
' Test dimension Variable tableau
If NumberOfArrayDimensions(a) = 2 Then
Tri a, 5, LBound(a, 1), UBound(a, 1)
a = Application.Transpose(a)
Else
a = Application.Transpose(a)
End If
' Transfert tableaux
For i = 1 To 7
ShF2.Cells(Cpt, i + 1).Resize(UBound(a, 2), 1) = Application.Index(Application.Transpose(a), , i)
Next i
ShF2.Cells(Cpt, 12).Resize(UBound(a, 2), 1) = Application.Index(Application.Transpose(a), , 8)
If Cpt = 4 Then
Transfert = ShF2.Cells(65536, 2).End(xlUp).Row + 3
Else
Transfert = ShF2.Cells(65536, 2).End(xlUp).Row + 1
End If
End Function
Sub Tri(ByRef a() As Variant, ByRef ColTri As Double, ByVal gauc As Double, ByVal droi As Double) ' Quick sort
Dim ref, g, d, k As Double
Dim temp As Variant
ref = a((gauc + droi) \ 2, ColTri)
g = gauc: d = droi
Do
Do While a(g, ColTri) < ref: g = g + 1: Loop
Do While ref < a(d, ColTri): d = d - 1: Loop
If g <= d Then
For k = LBound(a, 2) To UBound(a, 2)
temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
Next k
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, ColTri, g, droi)
If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub