Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
Renomear Arquivos conservando nomes
Renomear Arquivos conservando nomes
Pessoal, esse código retirei do site "Guiadoexcel", mas tentando tirar uma dúvida eles me informaram que não possuem mais fórum, então..
Quero renomear os arquivos da pasta Temp. Acontece que quero que os nomes originais permaneçam e seja acrescentado apenas o texto "ordem 0 -" nates do nome existente.
Suponha que o nome de dois arquivos dessa pasta seja "Carta Cobrança.pdf" e "Ofício.pdf"
o código deverá renomear como: "Ordem 01 - Carta Cobrnança.pdf" e Ordem 02 - Ofício.pdf"
segue o código:
Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Dim NomeAntigo As String
Dim MyFolder, MyFile, NewName As String, i As Integer
MyFolder = "c:\TEMP"
MyFile = Dir(MyFolder & "*.*")
Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")
'Chama a fun??o para renomear os arquivos
lsRenomearArquivos Caminho, NomeBase, NomeAntigo
End Sub
'Fun??o que renomea os arquivos
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String, NomeAntigo As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' n?o existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
i = InStr(1, MyFile, ".", 1)
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & "-" & NomeAntigo & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome
Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1
Next
End Sub
Quero renomear os arquivos da pasta Temp. Acontece que quero que os nomes originais permaneçam e seja acrescentado apenas o texto "ordem 0 -" nates do nome existente.
Suponha que o nome de dois arquivos dessa pasta seja "Carta Cobrança.pdf" e "Ofício.pdf"
o código deverá renomear como: "Ordem 01 - Carta Cobrnança.pdf" e Ordem 02 - Ofício.pdf"
segue o código:
Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Dim NomeAntigo As String
Dim MyFolder, MyFile, NewName As String, i As Integer
MyFolder = "c:\TEMP"
MyFile = Dir(MyFolder & "*.*")
Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")
'Chama a fun??o para renomear os arquivos
lsRenomearArquivos Caminho, NomeBase, NomeAntigo
End Sub
'Fun??o que renomea os arquivos
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String, NomeAntigo As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' n?o existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
i = InStr(1, MyFile, ".", 1)
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & "-" & NomeAntigo & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome
Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1
Next
End Sub
- Anexos
-
- RenomearArquivos.zip
- (17.46 KiB) Baixado 195 vezes
- Reinaldo
- Jedi
- Mensagens: 1537
- Registrado em: Sex Ago 01, 2014 4:09 pm
- Localização: Garça - SP / SCS - SP
Re: Renomear Arquivos conservando nomes
Não sei se entendi, mas substitua suas rotinas pela abaixo,
experimente e veja se atende.
experimente e veja se atende.
Código: Selecionar todos
Option Explicit
'Seleciona os arquivos
Public Sub lsSelecionaArquivo()
Dim MyFolder As String
'Defina/informe a pasta e hd a ser utilizado
MyFolder = "c:\TEMP"
'Chama a função para renomear os arquivos
lsRenomearArquivos MyFolder, "Z", "Z"
End Sub
'Rotina que renomeia os arquivos
Public Sub lsRenomearArquivos(ByVal Caminho As String, ByVal NomeBase As String, ByVal NomeAntigo As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' não existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
'Definição/formação do nome do arquivo existente/localizado
If NomeAntigo = "Z" Then NomeAntigo = Mid(Arquivo, Len(Caminho) + 2, Len(Arquivo) - 4 - Len(Caminho) - 1)
'Inclui na coluna "A" o nome e caminho do arquivo localizado
Cells(Linha, 1) = UCase$(Arquivo.Path)
'Definição/formação do novo nome do arquivo
lNovoNome = Caminho & "\" & Format(lSeq, "00") & "-" & NomeAntigo & Right(Arquivo, 4)
'Renomeia o arquivo localizado
Name Arquivo.Path As lNovoNome
'Inclui na coluna "B" o nome e caminho do arquivo renomeado
Cells(Linha, 2) = lNovoNome
'Redefine a variavel
NomeAntigo = "Z"
'Incrementa a numeração
lSeq = lSeq + 1
'Incrementa a linha da celula
Linha = Linha + 1
Next
End Sub
[RESOLVIDO]Renomear Arquivos conservando nomes
Perfeito Reinaldo. Muito obrigado meu amigo.
Caso possa dar uma ajuda na minha outra dúvida intitulada "Busca Avançada" eu agradeceria
Caso possa dar uma ajuda na minha outra dúvida intitulada "Busca Avançada" eu agradeceria
Re: Renomear Arquivos conservando nomes
Reinaldo, mais uma vez com esse problema, Gostaria que esse código vasculhasse todas as pastas dentro do diretório Temp e renomeasse os arquivos de todas conforme está fazendo, ou seja, quero que fça o que faz só que em todas as pastas que encontrar dento do diretório determinado,
Ainda, já vi em algum lugar como colocar essa palavra RESOLVIDO antes dos temas, mas não sei mais como fazer, Agradeço a dica.
Obrigado
Ainda, já vi em algum lugar como colocar essa palavra RESOLVIDO antes dos temas, mas não sei mais como fazer, Agradeço a dica.
Obrigado
- Reinaldo
- Jedi
- Mensagens: 1537
- Registrado em: Sex Ago 01, 2014 4:09 pm
- Localização: Garça - SP / SCS - SP
Re: Renomear Arquivos conservando nomes
"...em todas as pastas que encontrar dento do diretório determinado..."
Talvez algo +/-
Talvez algo +/-
Código: Selecionar todos
Public Sub lsSelecionaArquivo()
Dim MyFolder As String
Dim Fso As Object
Dim f As Folder, sf As Folder
'Defina/informe a pasta e hd a ser utilizado
MyFolder = "c:\TEMP"
'Chama a função para renomear os arquivos diretorio inicial
lsRenomearArquivos MyFolder, "Z", "Z"
'Chama a função para renomear os arquivos de cada subdiretorio encontrado
Set Fso = CreateObject("Scripting.FileSystemObject")
Set f = Fso.GetFolder(MyFolder)
For Each sf In f.SubFolders
Debug.Print sf.path
lsRenomearArquivos sf.path, "Z", "Z"
Next
End Sub
Re: Renomear Arquivos conservando nomes
Reinaldo, apresentou o seguinte erro na variável f:
- Anexos
-
- Tela erro
- Screenshot_20200319_154023.jpg (96.64 KiB) Exibido 6112 vezes
Re: Renomear Arquivos conservando nomes
Ok. Resolvido. Agora eu quero retirar apenas a primeira letra de todos os nomes de arquivos anteriores e só depois fazer a renomeaçao