JSDJSD

La que te muestra en el video es la que yo modifiqué, pero es indiferente prueba lo que te indica Antoni en la que el te mando o en la modificada la cuestión es seguir el paso a paso para ver donde esta el error para que no te funcione tanto una como la otra.

El archivo Extraer nombre de carpetas y subcarpetas1.xlsm

Si no entendí mal esto es lo que necesitas verdad ?

La modificación no es la tuya, es la mia 😂

Mañana te lo miro

Option Explicit Dim FileSystemObject As Object Sub ListOfFoldersAndFiles() Dim LookInTheFolder As String Dim searchfolders As Object Dim i As Long ' Limpiar contenido de la hoja Hoja1.Cells.Clear ' Escribir títulos en negrita With Hoja1.Range("B1:D1") .Value = Array("Subcarpetas", "Archivos", "Hipervínculos") .Font.Bold = True End With i = 2 LookInTheFolder = "C:\Users\JSD\Desktop\fotosvehiculos" ' Modifica según la ruta Set FileSystemObject = CreateObject("Scripting.FileSystemObject") Set searchfolders = FileSystemObject.GetFolder(LookInTheFolder) ListWithin searchfolders, i Hoja1.Columns("B:D").AutoFit End Sub Sub ListWithin(folder As Object, ByRef i As Long) Dim subfolder As Object Dim file As Object ' Listar subcarpetas For Each subfolder In folder.SubFolders Cells(i, 2) = subfolder.Path i = i + 1 ListWithin subfolder, i Next subfolder ' Listar archivos en la carpeta actual For Each file In folder.Files Cells(i, 3) = file.Path Cells(i, 4).Formula = "=HYPERLINK(""" & file.Path & """)" i = i + 1 Next file End Sub Extraer nombre de carpetas y subcarpetas1.xlsm

Será esto lo que necesitas ?

Tu archivo esta vacio

Sub ResumenMensual1(): Application.ScreenUpdating = False Dim Hoja As String, Acumulado(5, 6) As Double Dim h As Object ' Variable para iterar por las hojas Dim hojaEncontrada As Boolean ' Variable para indicar si se encontró la hoja With Sheets("RESUMEN MENSUAL") For x = 12 To .Range("D" & Rows.Count).End(xlUp).Row Step 6 'Borramos Acumulado semanales For f = 1 To 5 For c = 1 To 6 Acumulado(f, c) = 0 Next Next 'Por cada hoja de la semana For y = .Range("F" & x) To .Range("H" & x) Hoja = Replace(y, "/", "-") hojaEncontrada = False ' reiniciar la bandera en cada iteración 'Acumulamos cada día de la semana si existe For Each h In Sheets If h.Name = Hoja Then hojaEncontrada = True f = 0: c = 0 For fila = 14 To 18 f = f + 1 c = 0 For columna = 4 To 14 Step 2 c = c + 1 Acumulado(f, c) = Acumulado(f, c) + h.Cells(fila, columna) Next Next Exit For ' Salir del bucle una vez que se encontró la hoja End If Next h If hojaEncontrada Then 'Actualizamos RESUMEN For f = 1 To 5 For c = 1 To 6 .Cells(x + f - 1, c + 11) = Acumulado(f, c) Next Next '-- End If Next y Next x End With End Sub Pruebas.xlsb

Prueba ahora a ver si te funciona, es la macro del Maestro Antoni pero integrando la funcionalidad de la función directamente dentro de la macro

Funcionar, funciona perfectamente comprobado

tu archivo PRUEBA.xlsm

Adaptándome a tu código te dejo una posible solución, también veras que cuando digites valores en textbox1,3,5 y pulses enter el calculo aparecerá automáticamente en sus correspondientes textbox, intenta continuar con los siguientes

Si pones un ejemplo en el que se entienda todo el proceso de la conversión y el funcionamiento del formulario, lo intento

Sub ExportarCSV() Set hojaDatos = ThisWorkbook.Sheets("Datos") Set hojaCSV = ThisWorkbook.Sheets("CSV") ultimaFila = hojaDatos.Cells(hojaDatos.Rows.Count, "B").End(xlUp).Row Dim rangoCodigos As Range Set rangoCodigos = hojaDatos.Range("G1:IB1") rutaArchivoCSV = ThisWorkbook.Path & "\" nombreArchivoCSV = "archivo.csv" archivoCSV = FreeFile Open rutaArchivoCSV & nombreArchivoCSV For Output As archivoCSV For i = 2 To ultimaFila clave = hojaDatos.Cells(i, 2).Value mes = hojaDatos.Cells(i, 5).Value año = hojaDatos.Cells(i, 6).Value For Each celda In rangoCodigos codigo = celda.Value valor = hojaDatos.Cells(i, celda.Column).Value If Not IsEmpty(codigo) Then If IsNumeric(valor) Then valor = CDbl(valor) End If Print #archivoCSV, clave & "," & codigo & "," & valor & "," & mes & "," & año End If Next celda Next i Close archivoCSV MsgBox "Se ha generado el archivo CSV correctamente.", vbInformation End Sub Exportar datos a csv.xlsm

Prueba y comenta

Sube tu archivo

stock ALMACEN MMPP 2024 rev.1001 (1).xlsm

Tambien te modifico image, tanto en entrada como en salida para que te aparezcan las dos imágenes en tu excel ya que en ambos sitios tienen que tener el mismo nombre para que te aparezcan.

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui"> <ribbon startFromScratch="true"> <tabs> <tab id="DPS" label="DPS" insertBeforeMso="TabHome"> <group id="customGroup" label="Contoso Tools"> <button id="btnEntradas" label="Entradas" image="icoEntradas1" size="large" onAction="btnEntradas" /> <button id="btnSalidas" label="Salidas" image="icoSalidas" size="large" onAction="btnSalidas" /> </group> </tab> </tabs> </ribbon> </customUI> He modificado tu código, y con esto se ocultan todas sin necesidad de identificarlas una a una

Si nadie te contesta antes, mañana te lo miro

En el ejemplo te he puesto 1 segundo para no hacer largo el gif, cámbialo a tu necesidad

Sub RecorrerRangoC() Set hoja = ActiveSheet Set rango = hoja.Range("C2:C" & hoja.Cells(hoja.Rows.Count, "C").End(xlUp).Row) If rango.Cells.Count = 0 Then MsgBox "No hay datos en la columna C.", vbExclamation Exit Sub End If For Each celda In rango.SpecialCells(xlCellTypeVisible) celda.Select Application.Wait Now + TimeValue("00:00:01") Next celda End Sub Prueba y comenta

Sube tu archivo

Private Sub CommandButton1_Click() Dim celda As Range For Each celda In Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row) If IsNumeric(celda.Value) And celda.Value > 0 Then celda.HorizontalAlignment = xlLeft End If Next celda End Sub Numeros.xlsm