保存原件副本时另存为错误

Question

不知是否有人可以帮助我。

使用我在网上找到的脚本 'base' 我在下面编写了查询。

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

该脚本的目的是将一个 'master' 文件分割成更小的文件，将它们保存为 CSV。

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

我想做的是使用原始文件名作为新创建文件名的一部分来创建保存新创建的文件，然后关闭所有文件。

有人可以就我哪里出错提供一些指导吗？

非常感谢和亲切的问候

克里斯

Answer 1

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

这看起来像是一个无效名称，因为 fNameAndPath 已经是 Excel 文件的路径和名称，类似于 C:\Folder\something.csv，所以它不可能是文件夹。您试图在保存的文件名中包含 \？

如果您想在刚刚打开的csv文件的同一文件夹中创建不同的文件，您可以使用_（下划线，或OS中可接受的任何其他字符文件名）。所以你可以试试：

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

编辑

在进一步了解您的需求后，关于您想要实现的文件命名和拆分，我已经重构了您的代码。

基本上我在将 "File x.csv" 添加到名称之前删除了文件的扩展名。我还删除了 Copy/Paste 有利于分配值的东西（这应该会更快）因为你正在生成 csv 所以你不需要任何格式，只需要值。代码中的一些注释进一步限定了该方法。

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

再声明一个工作簿对象变量为

Dim wb1 As Workbook

打开文件时将文件分配给新的工作簿变量(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 字符串将不起作用，因为它具有文件夹地址和文件名

Answer 3

我还不能发表评论，但这是 A.S.H 的 post 评论的延续。

看来您只需要将 .csv 放在新文件名的中间即可。您可以使用

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

这将删除文件扩展名（CSV 或其他）。在您的 saveas 行之前执行此操作。

保存原件副本时另存为错误

Save As Error When Saving Copy of Original

excel

vba

save-as