Cambio de nombre de archivo y guardado

Desempolve un script que hice hace rato para una aplicación en visual basic, es harto código pero tiene la ventaja de que no utilizas controles, puro API
En fin vamos al tema:
Abre el editor de Visual basic ALT + F11
Inserta un "Modulo"... no un modulo de clase solo un "Modulo"
Al modulo dale doble click y pega esto:
NOTA: antes de correr el macro para renombrar tus archivos has una copia de seguridad de los mismos. El código funciona bien, pero siempre es bueno tener copia.
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFind As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private TotSize As Long
Private NumSubdirs As Long
Private NumArxius As Long
Public TA As Long
Const MiDir As String = "C:\PRUEBA\"
Dim MATRIZ() As String
Dim NL As String
Sub pasar()
Dim i As Integer
On Error GoTo Err
ChDir MiDir
inf MiDir
If TA = 0 Then MsgBox "No se encontraron archivos en carpeta " & MiDir, vbCritical: NL = "": Exit Sub
If TA > ActiveWorkbook.Sheets.Count Then MsgBox "El total de Archivos TXT supera al total de hojas disponibles en el libro actual", vbCritical: NL = "": Exit Sub
MATRIZ = Split(NL, "#")
Application.ScreenUpdating = False
For i = LBound(MATRIZ) + 1 To UBound(MATRIZ) - 1
'Call texto(i, MiDir & MATRIZ(i), MATRIZ(i))
Name MiDir & MATRIZ(i) As MiDir & "inf_cne_" & Mid(MATRIZ(i), 3, Len(MATRIZ(i)))
DoEvents
Next
Err: If Err.Number = 76 Then MsgBox "No se encontro la carpeta " & MiDir
NL = ""
Erase MATRIZ
Application.ScreenUpdating = True
MsgBox "Terminado"
End Sub
Private Function inf(miPath As String) As Long
Dim atribarx As Long, TotSize As Long
Dim valor1 As Long, valor2 As Long
Dim InfoTd As WIN32_FIND_DATA
Dim NomArxiu As String
On Error Resume Next
If Right(miPath, 1) <> "\" Then miPath = miPath & "\"
TotSize = 0
NumSubdirs = 0
NumArxius = 0
valor1 = 0
valor2 = True
valor1 = FindFirstFile(miPath & "*.*", InfoTd)
Do
NomArxiu = InfoTd.cFileName
atribarx = InfoTd.dwFileAttributes
If Left(NomArxiu, 1) <> "." Then
If atribarx And FILE_ATTRIBUTE_DIRECTORY Then
NumSubdirs = NumSubdirs + 1
Else
NumArxius = NumArxius + 1
End If
End If
valor2 = FindNextFile(valor1, InfoTd)
If valor2 > 0 Then NL = (NL & InfoTd.cFileName & "#")
Loop Until valor2 = 0
FindClose (valor1)
DoEvents
TA = NumArxius
DoEvents
DoEvents
TotSize = 0
NumSubdirs = 0
NumArxius = 0
End Function
antes de correrlo debes modificar esta linea:
Const MiDir As String = "C:\PRUEBA\"
Aquí debes reemplazar la ruta "C:\PRUEBA\" por la ruta en donde tu tienes los archivos que deseas renombrar.
Una vez realizado esto tener en cuenta lo siguiente:
He tomado la estructura que tu indicas por lo que entiendo que todos los archivos que renombraras tiene la forma "OPaammdd" . pues bien el macro se invoca como cualquier macro . ALT + F8
Se llama "pasar"
Lo que hace todo este código entre muchas cosas es Ver cuantos archivos existe en la carpeta que indicas ( también tamaño de archivos, tipo extensión, fecha de creación . etc)
Pero para tu caso, recorrerá uno a uno los archivos y tomando el prefjo "inf_cne_" y concatenandolo con la cadena original desde el tercer carácter hasta el ultimo y utilizando la instrucción "name " le asignara ese nuevo nombre compuesto.

Muchas gracias por responder.
Intenté correr la macro, pero en el siguiente comando me aparece un error, me dice que es necesaria una expresión de constante.
cFileName As String * MAX_PATH
Gracias nuevamente

Ups... sorry
Sobre esta linea
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Agrega esta
Private Const MAX_PATH = 64

Si te sirvió la respuesta, cierra la pregunta

Hola, cuando lo intento correr me sale el mensaje de que son demasiados archivos .txt. te aclaro que los archivos son 366 con extensión xls y deseo que permanezcan con esa extensión, pensé que había hecho algo mal, pero creo que no. Esperaba identificar por mi cuenta el problema pero no hay caso. Gracias

Perdona
Elimina esta linea
If TA > ActiveWorkbook.Sheets.Count Then MsgBox "El total de Archivos TXT supera al total de hojas disponibles en el libro actual", vbCritical: NL = "": Exit Sub

¿Y ahora? ¿Cómo salio?
Favor cierra la pregunta

Hola, sale el mensaje de terminado, pero no hay cambios en la carpeta en la que están los archivos, es decir no les cambia el nombre siguen siendo "opaammdd.kls" gracias

La verdad a mi me funciona bien.
Lo ultimo que me queda es enviarte el archivo de ejemplo vía mail, si deseas el ejemplo indicame a donde te lo envío.
Esto ya esta llevando muchos días.

Vale, perfecto, mi correo es [email protected], de verdad te agradezco tu voluntad, con esto cierro la pregunta y me las arreglo yo, gracias