JSDJSD

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

Private Sub FILTRAR_Click() Dim hojadatos As Worksheet Dim columna As Range Dim ultimafila As Long Dim dato As Variant Set hojadatos = ThisWorkbook.Sheets("IVASOPORTADO") Set columna = hojadatos.Columns("H") ActiveSheet.ListObjects("CLIENTES").Range.AutoFilter Field:=9, Criteria1:="10.00" ultimafila = Hoja5.Range("b" & Rows.Count).End(xlUp).Row dato = hojadatos.Cells(ultimafila, 9).Value txt_suma21 = dato End Sub Con esta modificación de tu código hace lo que supone que necesitas. Pero que pasa si quieres filtrar por un tipo de iva distinto? habría que estructurarlo de diferente forma.

Me alegro

Cambia estas dos lineas en tu còdigo txt_dani_general.Value = CDbl(txt_tejido_tapa.Value) + CDbl(txt_referencia.Value) '<<<<<<<<<<<<<<<<<<<< txt_suma.Value = CDbl(txt_suma) / 100000 ' <<<<<<<<<<<<<<<<<<<<< Private Sub BT_BUSCARARTICULO_Click() Dim Rango As Range Dim suma As Double Set Rango = Sheets("PRESUPUESTO1").Range("C4:CJ500000") txt_referencia = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 4, 0) txt_articulo = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 5, 0) txt_tejido_tapa = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 82, 0) txt_comision = Application.WorksheetFunction.VLookup(txt_escandallo.Value, Rango, 50, 0) '............................... <<<<<<<<<<Resto de tu còdigo '............................... On Error Resume Next txt_dani_general.Value = txt_tejido_tapa.Value & txt_referencia.Value '<<<<<<<<<< Modificar txt_suma.Value = txt_suma / 100000 '<<<<<<<<<< Modificar Me.LISTA.RowSource = "ARTICULOS9" Me.LISTA.ColumnCount = 9 End Sub