Como abrir los archivos de una carpeta para aplicarles una macro?
Tengo una carpeta con 30 archivos, como puedo abrirla y aplicarle una macro a cada archivo para cambiarles algunos parametros y guardarlos:
Los abro manualmente de uno en uno y aplico la macro control+w y se guardan automáticamente, ahora lo que requiero es que abra todos los archivos en automático y aplique la macro para no seguirlo haciendo de uno en uno
Esta es mi macro
Acceso directo: CTRL+w
'
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(9, 1), Array(14, 1), Array(21, 1), Array(27, 1)), _
TrailingMinusNumbers:=True
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("A1").Select
Application.ScreenUpdating = True
Range("A1") = "Lon"
Range("B1") = "Lat"
Range("C1") = "Tmax"
Range("D1") = "Edo"
Range("E1") = "Estacion"
Range("F1") = "Fecha"
libro = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) 'se le quita la extensión
libro2 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) 'dejar nombre sin extencion para reutilizarlo y guardarlo con el mismo nombre
fechax = Right(libro, 5)
fechaCol = Left(fechax, 2) & "/" & Mid(fechax, 3, 2) & "/20" & Right(fechax, 1) & "2"
finx = Range("A" & Rows.Count).End(xlUp).Row
Range("F2:F" & finx) = CDate(fechaCol)
ruta = ThisWorkbook.Path & "\"
ActiveWorkbook.SaveAs Filename:=libro2 & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
End Sub
Cuando termina la macro guarda el archivo en la misma carpeta de su origen
2 Respuestas
Pon la siguiente macro en tu libro. Pon tu libro en la misma carpeta donde tienes tus archivos y ejecuta la macro.
La macro abrirá todos los archivos txt de la carpeta, los modificará según tu macro y los guardará como csv.
Sub Abrir_Txt()
'Act Por Dante Amor
'Acceso directo: CTRL w
'
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path & "\"
archs = Dir(ruta & "*.txt")
Do While archs <> ""
Workbooks.OpenText Filename:=ruta & archs, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
Set l2 = ActiveWorkbook
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(9, 1), Array(14, 1), Array(21, 1), Array(27, 1)), _
TrailingMinusNumbers:=True
Rows("1:1").Delete Shift:=xlUp
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("A1").Select
Range("A1") = "Lon"
Range("B1") = "Lat"
Range("C1") = "Tmax"
Range("D1") = "Edo"
Range("E1") = "Estacion"
Range("F1") = "Fecha"
libro = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) 'se le quita la extensión
libro2 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) 'dejar nombre sin extencion para reutilizarlo y guardarlo con el mismo nombre
fechax = Right(libro, 5)
fechaCol = Left(fechax, 2) & "/" & Mid(fechax, 3, 2) & "/20" & Right(fechax, 1) & "2"
finx = Range("A" & Rows.Count).End(xlUp).Row
Range("F2:F" & finx) = CDate(fechaCol)
'
ruta = ThisWorkbook.Path & "\"
ActiveWorkbook.SaveAs Filename:=libro2 & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
l2.Close False
archs = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. '.[Avísame cualquier duda
Esto tal vez aporte algo más
[url=https://www.youtube.com/c/programarexcel?sub_confirmation=1]
https://www.youtube.com/c/programarexcel?sub_confirmation=1[/url]