Рандомное переименование файлов txt без повторов

Sub Перетасовать_Названия_файлов()
    Dim i&, j&, v, c As New Collection
 
    With CreateObject("scripting.filesystemobject")
        Randomize Timer
        For Each v In .getfolder(ThisWorkbook.Path).Files
            If LCase(Right$(v, 4)) = ".txt" Then c.Add v.Path
        Next
        
        For i = 1 To c.Count
            .MoveFile c(i), ThisWorkbook.Path & "\" & i & ".txt"
        Next
    
        For Each v In .getfolder(ThisWorkbook.Path).Files
            If LCase(Right$(v, 4)) = ".txt" Then
                j = Fix(Rnd * c.Count) + 1
                .MoveFile v.Path, c(j)
                c.Remove (j)
            End If
        Next
    End With
 
End Sub

Sub Перетасовать_Названия_файлов()
    Dim i&, j&, v, c As New Collection
    On Error Resume Next
    With CreateObject("scripting.filesystemobject")
        Randomize Timer
        For Each v In .getfolder(ThisWorkbook.Path).Files
            If LCase(Right$(v, 4)) = ".txt" Then c.Add v.Path
        Next
        
        For i = 1 To c.Count
            .MoveFile c(i), ThisWorkbook.Path & "\" & i * 1000 & ".txt"
        Next
    
        For Each v In .getfolder(ThisWorkbook.Path).Files
            If LCase(Right$(v, 4)) = ".txt" Then
                j = Fix(Rnd * c.Count) + 1
                .MoveFile v.Path, c(j)
                c.Remove (j)
            End If
        Next
    End With
 
End Sub

Sub bb()
Dim i&, f$
  Application.ScreenUpdating = False
  ChDir ThisWorkbook.Path
  f = Dir("*.txt")
  While f <> ""
    i = i + 1
    Cells(i, 1).Resize(, 2) = f
    f = Dir
  Wend
  With Range("B1:C" & i)
    .Columns(2).Formula = "=RAND()"
    .Sort Range("C1"), Header:=xlNo
  End With
  For i = 1 To i
    Name Cells(i, 1) As "~" & Cells(i, 2)
  Next
  For i = 1 To i - 1
    Name "~" & Cells(i, 2) As Cells(i, 2)
  Next
  Range("A:C").ClearContents
  Application.ScreenUpdating = True
End Sub