Actualizar Estatus de Archivos

Te muestro una aplicación para seleccionar tus archivos, poner un estatus y actualizar en automático los nombres de los archivos en la hoja con el estatus que escribiste.

Código:

---

Private Sub CommandButton1_Click()
'Por Dante Amor
  Dim sPath As String
  Dim sArch As Variant
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Selecciona la carpeta"
    If .Show <> -1 Then Exit Sub
    .InitialFileName = "C:\trabajo"
    sPath = .SelectedItems(1) & "\"
  End With
  
  sArch = Dir(sPath & "*.pdf")
  Do While sArch <> ""
    ListBox1.AddItem sPath & sArch
    sArch = Dir()
  Loop
End Sub

Private Sub CommandButton2_Click()
'Por Dante Amor
  Dim i As Long, lr As Long, nmax As Long
  Dim inicial As Boolean
  '
  If TextBox1.Value = "" Then
    MsgBox "Capturar el estatus", vbExclamation, "Excel y Macros"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  If ListBox1.ListCount = 0 Then
    MsgBox "Seleccionar Carpeta", vbExclamation, "Excel y Macros"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  lr = Range("A" & Rows.Count).End(3).Row + 1
  nmax = WorksheetFunction.Max(Range("A2:A" & lr)) + 1
  
  For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) Then
      Range("A" & lr).Value = nmax
      Range("B" & lr).Value = ListBox1.List(i)
      Range("C" & lr).Value = TextBox1.Value
      lr = lr + 1
      nmax = nmax + 1
      inicial = True
    End If
  Next
  Application.ScreenUpdating = True
  If inicial = False Then
    MsgBox "No se seleccionaron archivos", vbExclamation, "Excel y Macros"
  Else
    MsgBox "Estatus actualizado", vbInformation, "Excel y Macros"
    ListBox1.Clear
    TextBox1.Value = ""
    Unload Me
  End If
End Sub

Private Sub UserForm_Activate()
  ListBox1.MultiSelect = fmMultiSelectMulti
  ListBox1.ListStyle = fmListStyleOption
End Sub

---