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