Save As Error When Saving Copy of Original

Question

I wonder whether someone could help me please.

Using a script I found online as a 'base' I've written the query below.

Sub Test()
  Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range    'data (range) of header row
  Dim WorkbookCounter As Integer
  Dim RowsInFile           'how many rows (incl. header) in new files?
  Dim fNameAndPath As Variant


  fNameAndPath = Application.GetOpenFilename(Title:="Select File To Be Opened")
  If fNameAndPath = False Then Exit Sub
  Workbooks.Open Filename:=fNameAndPath


  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ActiveWorkbook.Worksheets(1)
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 50    'as your example, just 1000 rows per file

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))


  For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
    Set wb = Workbooks.Add

  'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1")

  'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

  'Save the new workbook, and close it

  Application.ScreenUpdating = False

  With wb
    .SaveAs Filename:=fNameAndPath & "\File " & WorkbookCounter, FileFormat:=xlCSV
    wb.Close False
    Application.DisplayAlerts = True
 End With

  'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

The purpose of the script takes a 'master' file and splits into smaller files saving them as a CSV.

With wb
    .SaveAs Filename:=fNameAndPath & "\File " & WorkbookCounter, FileFormat:=xlCSV
    wb.Close False
    Application.DisplayAlerts = True
 End With

What I'm trying to do is create save the newly created file(s) using the original filename as the part of the newly created filename then close all files.

Could some perhaps offer some guidance on where I've gone wrong?

Many thanks and kind regards

Chris

Answer 1

.SaveAs Filename:=fNameAndPath & "\File " & WorkbookCounter, FileFormat:=xlCSV
'                                ^^^

That looks like an invalid name, since fNameAndPath is already the path and name of an Excel file, something like C:\Folder\something.csv, so it can't be a folder. You are trying to have a \ in the saved file's name?

If what you want is to create different files in the same folder of the csv file you just opened, you can use _ (underscore, or any other character acceptable by the OS in file names). so you can try instead:

.SaveAs Filename:=fNameAndPath & "_File " & WorkbookCounter, FileFormat:=xlCSV
'                                ^^^

EDIT

After better understanding your requirements, regarding the file naming and the splitting that you want to achieve, I have re-factored your code.

Basically I remove the file's extension before adding "File x.csv" to the name. I also removed Copy/Paste stuff in favor of assigning values (which should go faster) since you are generating a csv so you don't want any formats, just values. Some comments in the code further qualify the approach.

Sub SplitWorksheet()
  Dim rowsPerFile As Long: rowsPerFile = 50 ' <-- Set to appropriate number

  Dim fNameAndPath
  fNameAndPath = Application.GetOpenFilename(Title:="Select File To split")
  If fNameAndPath = False Then Exit Sub
  Dim wbToSplit As Workbook: Set wbToSplit = Workbooks.Open(Filename:=fNameAndPath)

  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  On Error GoTo Cleanup

  Dim sheetToSplit As Worksheet: Set sheetToSplit = wbToSplit.Worksheets(1)
  Dim numOfColumns As Long: numOfColumns = sheetToSplit.UsedRange.Columns.Count
  Dim wbCounter As Long: wbCounter = 1 ' auto-increment for file names

  Dim rngHeader As Range, rngToCopy As Range, newWb As Workbook, p  As Long
  Set rngHeader = sheetToSplit.Range("A1").Resize(1, numOfColumns) ' header row

  For p = 2 To sheetToSplit.UsedRange.Rows.Count Step rowsPerFile - 1
    ' Get a chunk for each new workbook
    Set rngToCopy = sheetToSplit.Cells(p, 1).Resize(rowsPerFile - 1, numOfColumns)
    Set newWb = Workbooks.Add
    ' copy header and chunk
    newWb.Sheets(1).Range("A1").Resize(1, numOfColumns).Value = rngHeader.Value
    newWb.Sheets(1).Range("A2").Resize(rowsPerFile - 1, numOfColumns).Value = rngToCopy.Value2

    ' Save the new workbook with new name then close it
    ' Remove extension from original name then add "_File x.csv"
    Dim newFileName As String
    newFileName = Left(fNameAndPath, InStrRev(fNameAndPath, ".") - 1)
    newFileName = newFileName & "_File " & wbCounter & ".csv"

    newWb.SaveAs Filename:=newFileName, FileFormat:=xlCSV
    newWb.Close False
    wbCounter = wbCounter + 1
  Next p

Cleanup:
  If Err.Number <> 0 Then MsgBox Err.Description
  If Not wbToSplit Is Nothing Then wbToSplit.Close False
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Answer 2

Declare one more workbook object variable as

Dim wb1 As Workbook

when open file assign file to new workbook variable(wb1)-

Set wb1 = Workbooks.Open(Filename:=fNameAndPath)

With wb
 .SaveAs Filename:=wb1.Path & "\" & Left(wb1.Name, InStr(wb1.Name, ".") - 1) & "_File " & WorkbookCounter, FileFormat:=xlCSV
  wb.Close False
  Application.DisplayAlerts = True
End With

fNameAndPath string will not work as it has folder address with file name

Answer 3

I cant comment yet but this is a continuation of the comments from A.S.H's post.

I looks like you just need to drop the .csv in the middle of your new file name. You can do this by using

fNameAndPath = Left(ThisWorkbook.FullName, (InStrRev(ThisWorkbook.FullName, ".", -1, vbTextCompare) - 1))

This will drop the file extension (CSV or otherwise). Do this before your saveas line.