Trier colonne en Fonction autre colonne

Question

Bonjour à tous;

Alors voila mon problème

La feuille Excel contient déjà une colonne avec des noms et prénoms, classées sous un ordre précis.
Je dispose une macro qui Extraire le chemin de plusieurs fichiers code Qr en format Png.
Le problème est le suivant :
je voudrais que les chemins des Fichiers extraient dans même ordre dans colonne "D"
Est-il possible de réorganiser l'ordre de colonne "E", en se basant sur les noms de colonne "D" ?
Merci d'avance pour votre aide.

Veuillez voir la pièce ci-jointe pour plus de renseignements.

Sub CreateQrcode()
Dim URL As String
Dim codetext As String
Dim folderPath As String
Dim filePath As String
Dim LastRow As Long
Dim i As Long
Dim Fic As String

   URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl="
   folderPath = "C:\Users\ZAD INFO\Desktop\TEST3\QRCodes\"
   LastRow = Sheets("Base").Cells(Rows.Count, "D").End(xlUp).Row
   If Dir(filePath, vbDirectory) = " " Then
   MkDir folderPath
   End If

For i = 2 To LastRow
codetext = Sheets("Base").Cells(i, "D").Value
codetext = WorksheetFunction.EncodeURL(codetext)

URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl=" & codetext
filePath = folderPath & Cells(i, "D").Value & ".png"
DownloadFile URL, filePath
Next i
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\ZAD INFO\Desktop\TEST3\QRCodes")

i = 1
'For Each objFile In objFolder.Files
'    Range(Cells(i + 1, 15), Cells(i + 1, 15)).Select

'    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
'        objFile.Path, _
'        TextToDisplay:=objFile.Name
'    i = i + 1
'Next objFile

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\ZAD INFO\Desktop\TEST3\QRCodes")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
    'print file name
    Cells(i + 1, 5) = objFile.Path
    'print file path
   ' Cells(i + 1, 17) = objFile.Path
    i = i + 1
Next objFile

MsgBox "Terminer ", vbInformation

End Sub

Sub DownloadFile(URL As String, filePath As String)
Dim WinHttpReq  As Object
Dim oStream As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Set oStream = CreateObject("ADODB.Stream")

WinHttpReq.Open "GET", URL, False
WinHttpReq.send

If WinHttpReq.Status = 200 Then
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile filePath, 2
oStream.Close
End If
Set oStream = Nothing
Set WinHttpReq = Nothing

End Sub

Remarque : je n'ai pas pu envoyer tous le dossier

Bien cordialement,

DanielC · Accepted Answer

Corrigé. Le résultat se trouve en colonne F Sub Trier() Dim C As Range, Tbl() As String, Txt As String, i As Long Dim Pos As Variant, Tbl1() As String ReDim Tbl(Application.CountA(&#91;D:D&#93;) - 2) ReDim Tbl1(Application.CountA(&#91;D:D&#93;) - 2) i = -1 For Each C In Range("E2", Cells(Rows.Count, 5).End(xlUp)) Txt = Mid(C, InStrRev(C, "\") + 1, 9 ^ 9) Txt = Left(Txt, Len(Txt) - 4) i = i + 1 Tbl(i) = Txt Tbl1(i) = C Next C For Each C In Range("D2", Cells(Rows.Count, 4).End(xlUp)) Pos = Application.Match(C, Tbl, 0) If IsNumeric(Pos) Then C.Offset(, 2) = Tbl1(Pos - 1) End If Next C End Sub Daniel...

DanielC · Answer

Essaie comme ça : Sub Trier() Dim C As Range, Tbl() As String, Txt As String, i As Long Dim Pos As Variant, Tbl1() As String ReDim Tbl(Application.CountA(&#91;D:D&#93;) - 2) ReDim Tbl1(Application.CountA(&#91;D:D&#93;) - 2) i = -1 For Each C In Range("E2", Cells(Rows.Count, 5).End(xlUp)) Txt = Right(C, Len(C.Offset(, -1)) + 4) Txt = Left(Txt, Len(Txt) - 4) i = i + 1 Tbl(i) = Txt Tbl1(i) = C Next C For Each C In Range("D2", Cells(Rows.Count, 4).End(xlUp)) Pos = Application.Match(C, Tbl, 0) If IsNumeric(Pos) Then C.Offset(, 2) = Tbl1(Pos - 1) End If Next C End Sub Sub CreateQrcode() Dim URL As String Dim codetext As String Dim folderPath As String Dim filePath As String Dim LastRow As Long Dim i As Long Dim Fic As String URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl=" folderPath = "C:\Users\ZAD INFO\Desktop\TEST3\QRCodes\" LastRow = Sheets("Base").Cells(Rows.Count, "D").End(xlUp).Row If Dir(filePath, vbDirectory) = " " Then MkDir folderPath End If For i = 2 To LastRow codetext = Sheets("Base").Cells(i, "D").Value codetext = WorksheetFunction.EncodeURL(codetext) URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl=" & codetext filePath = folderPath & Cells(i, "D").Value & ".png" DownloadFile URL, filePath Next i Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder("C:\Users\ZAD INFO\Desktop\TEST3\QRCodes") i = 1 'For Each objFile In objFolder.Files ' Range(Cells(i + 1, 15), Cells(i + 1, 15)).Select ' ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ ' objFile.Path, _ ' TextToDisplay:=objFile.Name ' i = i + 1 'Next objFile 'Create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Get the folder object Set objFolder = objFSO.GetFolder("C:\Users\ZAD INFO\Desktop\TEST3\QRCodes") i = 1 'loops through each file in the directory and prints their names and path For Each objFile In objFolder.Files 'print file name Cells(i + 1, 5) = objFile.Path 'print file path ' Cells(i + 1, 17) = objFile.Path i = i + 1 Next objFile Trier MsgBox "Terminer ", vbInformation End Sub Sub DownloadFile(URL As String, filePath As String) Dim WinHttpReq As Object Dim oStream As Object Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1") Set oStream = CreateObject("ADODB.Stream") WinHttpReq.Open "GET", URL, False WinHttpReq.send If WinHttpReq.Status = 200 Then oStream.Open oStream.Type = 1 oStream.Write WinHttpReq.responseBody oStream.SaveToFile filePath, 2 oStream.Close End If Set oStream = Nothing Set WinHttpReq = Nothing End Sub Daniel...

DanielC · Answer

Désolé, mais sans classeur pour tester... Daniel...