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

Question

我想知道是否有人可以帮助我。

使用我在网上找到的脚本作为“基础”，我编写了下面的查询。

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

脚本的目的是获取一个“主”文件并将其拆分为较小的文件，并将它们保存为 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 文件的同一个文件夹中创建不同的文件，您可以使用_（下划线，或文件名中操作系统可接受的任何其他字符）。所以你可以试试：

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

编辑

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

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

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 帖子中 cmets 的延续。

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

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

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