Cargar una carpeta con archivos

Buenas! Tengo diseñado un Userform, en el cual quiero meter un boton, que seleccione una carpeta de mi disco. Y que la ruta de esta carpeta me la indique en un label Una vez echo esto, tendría una lista desplegable con los archivos

1 respuesta

Respuesta
1
A ver, tengo un codigo que puede ayudarte, lo que necesitas es:
Un formulario con un boton de comando, etiqueta, un combobox y otro boton de comando para cerrar el formulario.
El codigo para el formulario es:
Private Sub cmdGetDir_Click()
    Workbooks("Factura.xls").Activate
    ActiveWorkbook. Sheets("Sheet4"). Activate
    Application. GetSaveAsFilename,,, "Seleccione la ruta"
    Me.Label1.Caption = CurDir
    Range("B5").Select
    With ActiveCell
        .Value = CurDir
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .IndentLevel = 1
        .Font.Color = RGB(128, 0, 0)
        .Font.Bold = True
    End With
    Call ListArchivos
    Call dRanArch
    Sheets("Sheet5").Visible = True
    ActiveWorkbook.Sheets("Sheet5").Activate
    Application.Goto reference:="RanArchivos"
    RanLista = Selection.Address
    With Me.cmbLista
        .Value = ""
        .RowSource = RanLista
        .BackColor = RGB(240, 242, 239)
        .ForeColor = RGB(0, 0, 136)
    End With
    Sheets("Sheet5").Visible = False
    Range("A1").Activate
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub
Sub ListArchivos()
    On Error Resume Next
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    ruta = UserForm2.Label1.Caption
    Set directorio = fso.GetFolder(ruta)
    Set ficheros = directorio.Files
    ActiveWorkbook.Sheets("Sheet5").Visible = True
    ActiveWorkbook.Sheets("Sheet5").Activate
    Range("A1").Select
    ActiveCell = "Ficheros del directorio:"
    ActiveCell.Font.Bold = True
    ActiveCell.Font.Underline = xlUnderlineStyleSingle
    Range("A2").Select
    For Each archivo In ficheros
    ActiveCell = archivo.Name
    ActiveCell.Offset(1, 0).Select
    Next
    Set fso = Nothing
    Set directorio = Nothing
    Set ficheros = Nothing
    Application.ScreenUpdating = True
    ActiveWorkbook.Sheets("Sheet5").Visible = False
End Sub
Private Sub dRanArch()
    Dim rpIni$, rpFin$
    rpIni = "A2"
    Sheets("Sheet5").Visible = True
    ActiveWorkbook.Sheets("Sheet5").Activate
    Range(rpIni).Select
    Do
    If IsEmpty(ActiveCell) = False Then
    ActiveCell.Offset(1, 0).Select
    End If
    Loop Until IsEmpty(ActiveCell) = True
    rpFin = ActiveCell.Offset(-1, 0).Address
    ActiveWorkbook.Names.Add Name:="RanArchivos", RefersToR1C1:=Range(rpIni, rpFin)
    Sheets("Sheet5").Visible = False
    Sheets("Sheet4").Activate
End Sub
Private Sub UserForm_Initialize()
    Call dRanArch
    Sheets("Sheet5").Visible = True
    ActiveWorkbook.Sheets("Sheet5").Activate
    Application.Goto reference:="RanArchivos"
    RanLista = Selection.Address
    With Me.cmbLista
        .Value = ""
        .RowSource = RanLista
        .BackColor = RGB(240, 242, 239)
        .ForeColor = RGB(0, 0, 136)
    End With
    Me.cmdGetDir.SetFocus
    Sheets("Sheet5").Visible = False
End Sub
Lo he probado y me ha funcionado muy bien.
P.D. Si tu duda ha sido resuelta, no olvides finalizar la pregunta.
No consigo echarlo a andar,  no encuentra la macro..... eso pone..
habria la posibilidad que me mandaras un ejemplo?¿
Un saludo, gracias por el interes!
Claro, solo enviame una direccion electronica a donde enviarte el ejemplo.
Es probable que el error que te marca sea porque la macro hace uso de una hoja oculta, pero en el ejemplo ya la he incluido para que la macro este funcional, solo dime a donde te lo envio.
Ya te lo he enviado, confirma si todo va bien

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas