Modify Sheet killer to just clean sheet content and not erase it completely

Asked

Viewed 44 times

-1

I’m using the following code I got here on the site

    Sub Listar_Pastas()
    ''''''''''''''''''''
    '====  Pastas  ===='
    ''''''''''''''''''''
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xPath As String
    Dim xWs_pastas As Worksheet
    Dim fso As Object
    Dim fso_FOLDER As Object
    Dim fso_folders As Object
    Dim i As Long
    Dim textoparacoluna As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    'Janela para escolher a pasta do diretório desejado
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Escolha a pasta"
        .Show
         If .SelectedItems.Count = 0 Then
   Else
    xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

    End If
    'Alternatively, "if .selecteditems.count = 1 then myvar = .selecteditems(1)" can be used
    End With
    'On Error Resume Next
    If xPath = "" Then
        GoTo CleanExit                           'Se o caminho da pasta não existir


    End If
    'Define novo Objeto FSO GetFolder
    Set fso_FOLDER = fso.GetFolder(xPath)
    'Apaga se houver planilha com mesmo nome existente
    SheetKiller (fso_FOLDER.Name)
    'Cria nova planilha da pasta
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(Sheets.Count)).Name = fso_FOLDER.Name
    Set xWs_pastas = ThisWorkbook.Sheets(fso_FOLDER.Name)

    'https://stackoverflow.com/a/31428399/7690982
    'Encontra todos os Arquivos
    i = 3
    If fso_FOLDER.subFolders.Count > 0 Then
        'Loop em cada pasta do diretório escolhido
        For Each fso_folders In fso_FOLDER.subFolders
            With xWs_pastas
                'Preenche a coluna A com a lista de arquivos
                    .Cells(i, "A") = fso_folders.Name
                 End With
            i = i + 1
        Next fso_folders
    Else
        MsgBox "Nenhuma pasta encontrada em " & xPath
        GoTo CleanExit
    End If

     If xPath <> "" Then
     Call TextoParaColuna
    End If

    'Sair do código
CleanExit:

    Set fso = Nothing
    Set fso_FOLDER = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Ocorreu um erro em: " & Err.Number & " " & Err.Description
End Sub

Public Function SheetKiller(Name As String)
    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

It works the way I had asked but I need to make a modification in the part where it erases if there is a spreadsheet with an existing name, I even tried some things, but I ended up creating some very strange mistakes that Leave the whole spreadsheet.

What I need is that when it detects that the spreadsheet already exists,

1 answer

2


Follow the complete code with the modification:

      Sub Listar_Pastas()
    ''''''''''''''''''''
    '====  Pastas  ===='
    ''''''''''''''''''''
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim xPath As String
    Dim xWs_pastas As Worksheet
    Dim fso As Object
    Dim fso_FOLDER As Object
    Dim fso_folders As Object
    Dim i As Long
    Dim textoparacoluna As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    'Janela para escolher a pasta do diretório desejado
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Escolha a pasta"
        .Show
         If .SelectedItems.Count = 0 Then
   Else
    xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

    End If
    'Alternatively, "if .selecteditems.count = 1 then myvar = .selecteditems(1)" can be used
    End With
    'On Error Resume Next
    If xPath = "" Then
        GoTo CleanExit                           'Se o caminho da pasta não existir


    End If
    'Define novo Objeto FSO GetFolder
    Set fso_FOLDER = fso.GetFolder(xPath)
    'Apaga se houver planilha com mesmo nome existente
    SheetKiller (fso_FOLDER.Name)
    'Cria nova planilha da pasta
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(Sheets.Count)).Name = fso_FOLDER.Name
    Set xWs_pastas = ThisWorkbook.Sheets(fso_FOLDER.Name)

    'https://stackoverflow.com/a/31428399/7690982
    'Encontra todos os Arquivos
    i = 3
    If fso_FOLDER.subFolders.Count > 0 Then
        'Loop em cada pasta do diretório escolhido
        For Each fso_folders In fso_FOLDER.subFolders
            With xWs_pastas
                'Preenche a coluna A com a lista de arquivos
                    .Cells(i, "A") = fso_folders.Name
                 End With
            i = i + 1
        Next fso_folders
    Else
        MsgBox "Nenhuma pasta encontrada em " & xPath
        GoTo CleanExit
    End If

     If xPath <> "" Then
     Call textoparacoluna
    End If

    'Sair do código
CleanExit:

    Set fso = Nothing
    Set fso_FOLDER = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Ocorreu um erro em: " & Err.Number & " " & Err.Description
End Sub

Public Function SheetKiller(Name As String)
    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
            Sheets(i).Cells.ClearContents
            Application.DisplayAlerts = True
        End If
    Next i
End Function
  • In case I can’t delete the spreadsheet because it causes an error in a dynamic table that I have, then the spreadsheets that are the months (from 1 to 12) should always exist, but when clicking on the macro and listing the month 4 for example, the content has to be deleted but the spreadsheet must continue to exist so as not to spoil the dynamic table. I don’t know if there’s any other way to do it

  • Changed code, now it will just clean the desired spreadsheet

Browser other questions tagged

You are not signed in. Login or sign up in order to post.