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
.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 ' ^^^
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
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
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.