0

Tenho uma pasta chamada "Franquiados" onde há enumeras subpastas com os nomes dos franquiados. Dentro da pasta de cada franqueado existem algumas subpastas cujos nomes contém parênteses retos.

Quero programar uma macro para eliminar os parênteses retos dessas subpastas sem alterar o restante nome das mesmas.

Por ex:

Nome Atual C:\Users\jcoutinho006\Desktop\Franquiados\Fernando Soares\[04] Catálogo de Tratamento de Dados Pessoais_

Nome depois de usar a macro C:\Users\jcoutinho006\Desktop\Franquiados\Fernando Soares\04 Catálogo de Tratamento de Dados Pessoais_

Alguém sabe dizer que código devo usar?

0

1 Resposta 1

1

Isto pode ser realizado da seguinte maneira:

  • Escolha da pasta principal
  • Loop nas pastas e subpastas para listagem destas
  • Escrever as pastas e subpastas encontradas numa planilha temporária chamada "temp", retirando "[" ou "]"
  • Renomear com um loop para trás com Step -1 (pois há erros se começar a renomear pelas pastas e não subpastas)

Código de Exemplo

Sub Renomear_Pastas()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xDir As String
    Dim folder As Object
    Dim i As Long, linha As Long
    
    'Adiciona Planilha Temporária
    Dim temp As Worksheet
    SheetKiller ("temp")
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(Sheets.Count)).Name = "temp"
    Set temp = ThisWorkbook.Sheets("temp")
    
    'Escolher o Diretório
    Set folder = Application.FileDialog(msoFileDialogFolderPicker)
    With folder
        .Title = "Escolha a pasta"
    End With
    If folder.Show <> -1 Then GoTo CleanExit
    On Error Resume Next
    xDir = folder.SelectedItems(1) & "\"
    'Função para retirar Parêneteses Reto ou Colchetes
    retirar_pr xDir
  
    'Renomear
    linha = temp.Range("A" & temp.Rows.Count).End(xlUp).Row
    For i = linha To 2 Step -1
        Name temp.Cells(i, "A") As temp.Cells(i, "B")
    Next i

    'Sair do código
CleanExit:
    
    Set fso = Nothing
    Set fso_FOLDER = Nothing
    SheetKiller ("temp")
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Sub retirar_pr(ByVal xFolderName As String)
    Dim xFileSystemObject As Object
    Dim xFolder As Object
    Dim xSubFolder As Object
    Dim xFile As Object
    Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFileSystemObject.GetFolder(xFolderName)
    Dim nome_pasta As String, caminho As String, nova_pasta As String
    Dim linha As Long
    Dim temp As Worksheet
    Set temp = ThisWorkbook.Sheets("temp")
    
    'Loop em cada Subpasta
    For Each xSubFolder In xFolder.SubFolders
        'Procurar pela pasta e retirar [ ou ]
        nome_pasta = Right(xSubFolder, Len(xSubFolder) - InStrRev(xSubFolder, "\"))
        'Caso possua [ ou ]
        If InStr(nome_pasta, "[") Or InStr(nome_pasta, "]") Then
            linha = temp.Range("A" & temp.Rows.Count).End(xlUp).Row + 1
            nome_pasta = Replace(nome_pasta, "[", "")
            nome_pasta = Replace(nome_pasta, "]", "")
            caminho = Left(xSubFolder, InStrRev(xSubFolder, "\"))
            nova_pasta = caminho & nome_pasta
            'Escreve na planilha temporária os nomes antigos e novo da nova pasta
            temp.Cells(linha, "A") = xSubFolder
            temp.Cells(linha, "B") = nova_pasta
            retirar_pr xSubFolder.Path
        End If
    Next xSubFolder

    Set xFile = Nothing
    Set xFolder = Nothing
    Set xFileSystemObject = Nothing
End Sub

Public Function SheetKiller(Name As String)
    'Remove Planilha
    Dim s As Worksheet, t As String
    Dim i As Long, k As Long
    k = ThisWorkbook.Sheets.Count

    For i = k To 1 Step -1
        t = ThisWorkbook.Sheets(i).Name
        If t = Name Then
            Application.DisplayAlerts = False
            ThisWorkbook.Sheets(i).Delete
            Application.DisplayAlerts = True
        End If
    Next i
End Function

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .