Check if a filename already exist before creating a new excel file

Question

With the help of others, I was able to build this working code. I do however need help in adding conditions to it.

Before the worksheets are moved to a new file it must first check if a file of the same name already exist. If one does exist, then it should just update it (paste new data at the bottom). If none exist, then it should create one (which is what this code is doing)

Sub ExportSheets()
' Export segregated sheets to individual workbooks

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim sPath As String, sAddress As String, wsCur As Worksheet
Dim arrNoMoveSh, mtchSh
Dim sht As String
Dim x As Range
Dim rng As Range
Dim last As Long
Dim ControllerTab As Worksheet
Dim ControllerTabBase As Range

    Set ControllerTab = ThisWorkbook.Worksheets("Controller")
    Set ControllerTabBase = ControllerTab.Range("B1")

 ' --Creates an array of the sheet names to not be moved
 arrNoMoveSh = Split("Read Me,Validations,Controller,MTI Data,Other", ",")

 ' --Store path of this workbook
 sPath = ThisWorkbook.path & Application.PathSeparator

 ' --Loop through worksheets
 For Each wsCur In ThisWorkbook.Worksheets
      mtchSh = Application.Match(wsCur.Name, arrNoMoveSh, 0)
      If IsError(mtchSh) Then 'no sheet names found in the array
          wsCur.Copy 'create a new workbook for the sheet to be copied!!!

' --Specifies the sheet name in which the data is stored
sht = wsCur.Name

last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:P" & last)

Sheets(sht).Range("N1:N" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True

For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
    With rng
    .AutoFilter Field:=14, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy

    Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
    ActiveSheet.Paste
    End With

Next x

    Sheets(sht).Activate
    Sheets(sht).Delete

        ActiveWorkbook.SaveAs sPath & wsCur.Name & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=True

     End If

Next wsCur

Application.ScreenUpdating = True
Application.DisplayAlerts = True

ControllerTab.Activate
ControllerTabBase.Select

End Sub

user_9814069 · Answer

Export Worksheets to Workbooks

Option Explicit

Sub ExportWorksheets()
    
    Dim siws As Worksheet: Set siws = ThisWorkbook.Worksheets("Controller")
    Dim siCell As Range: Set siCell = siws.Range("B1")
    
    Dim Exceptions() As String
    Exceptions = Split("Read Me,Validations,Controller,MTI Data,Other", ",")
    
    Dim sPath As String: sPath = ThisWorkbook.Path & Application.PathSeparator
    
    Application.ScreenUpdating = False
    
    Dim sws As Worksheet
    Dim sName As String
    
    Dim dwb As Workbook
    Dim dws As Workbook
    Dim drg As Range
    Dim dCell As Range
    Dim dlRow As Long
    Dim dFilePath As String
    Dim dName As String
    Dim dnws As Worksheet ' existing worksheet
    Dim ddrg As Range ' excluding headers
    
    For Each sws In ThisWorkbook.Worksheets
        sName = sws.Name
        If IsError(Application.Match(sName, Exceptions, 0)) Then ' not found
            dFilePath = sPath & sName & ".xlsx"
            
            If Len(Dir(dFilePath)) = 0 Then ' file doesn't exist
                
                ' Copy to workbook.
                sws.Copy
                Set dwb = Workbooks(Workbooks.Count)
                Set dws = dwb.Worksheets(sName)
                dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
                Set drg = dws.Range("A1:P" & dlRow)
                
                ' Advance Filter
                dws.Range("N1:N" & dlRow).AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=dws.Range("BB1"), Unique:=True
            
                ' Copy to worksheets.
                For Each dCell In dws.Range("BB2", _
                        dws.Cells(dws.Rows.Count, "BB").End(xlUp)).Cells
                    dName = dCell.Value
                    With drg
                        .AutoFilter Field:=14, Criteria1:=dName
                        .SpecialCells(xlCellTypeVisible).Copy
                        dwb.Worksheets.Add(After:=dwb.Sheets( _
                            dwb.Sheets.Count)).Name = dName
                        ActiveSheet.Paste
                    End With
                Next dCell
            
                ' Save.
                Application.DisplayAlerts = False
                dws.Delete
                Application.DisplayAlerts = True
                dwb.SaveAs Filename:=dFilePath
                dwb.Close SaveChanges:=False
            
            Else ' file exists
                
                ' Copy to workbook.
                Set dwb = Workbooks.Open(dFilePath)
                sws.Copy Before:=dwb.Sheets(1)
                Set dws = dwb.Worksheets(sName)
                dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
                Set drg = dws.Range("A1:P" & dlRow)
                Set ddrg = dws.Range("A2:P" & dlRow)
                
                ' Advanced Filter
                dws.Range("N1:N" & dlRow).AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=dws.Range("BB1"), Unique:=True
            
                ' Copy to worksheets.
                For Each dCell In dws.Range("BB2", _
                        dws.Cells(dws.Rows.Count, "BB").End(xlUp)).Cells
                    dName = dCell.Value
                    On Error Resume Next
                        Set dnws = dwb.Worksheets(dName)
                    On Error GoTo 0
                    If dnws Is Nothing Then ' worksheet doesn't exist...
                        With drg ' ... the same as when file doesn't exist
                            .AutoFilter Field:=14, Criteria1:=dName
                            .SpecialCells(xlCellTypeVisible).Copy
                            dwb.Worksheets.Add(After:=dwb.Sheets( _
                                dwb.Sheets.Count)).Name = dName
                            ActiveSheet.Paste
                        End With
                    Else ' worksheet already exists
                        drg.AutoFilter Field:=14, Criteria1:=dName
                        ddrg.SpecialCells(xlCellTypeVisible).Copy _
                            dnws.Cells(dnws.Rows.Count, "A").End(xlUp).Offset(1)
                        Set dnws = Nothing
                    End If
                Next dCell
            
                ' Save.
                Application.DisplayAlerts = False
                dws.Delete
                Application.DisplayAlerts = True
                dwb.Close SaveChanges:=True
            
            End If
            
        'Else ' is in the exceptions list; do nothing
        End If
    
    Next sws
    
    ' Finishing Touches
    siws.Select
    siCell.Select
    Application.ScreenUpdating = True
    MsgBox "Worksheets exported.", vbInformation

End Sub

user_8695156 · Answer

Here's a function to determine whether a file currently exists:

Private Function FileExists(FileName As String) As Boolean
    On Error Resume Next
    FileExists = CBool(FileLen(FileName) + 1)
End Function

user_9912714 · Answer

Function FileExists(FileName As String) As Boolean
    FileExists = Len(Dir(FileName)) > 0
End Function

Usage

I would add the FileExists(FileName) clase to the existing If statement.

    FileName = sPath & wsCur.Name & ".xlsx"
    If IsError(mtchSh) And Not FileExists(FileName) Then 'no sheet names found in the array

Check if a filename already exist before creating a new excel file

3 Answers

Export Worksheets to Workbooks

Usage