2

我正在尝试将 Excel 工作簿从文件夹 X 复制到文件夹 Y，并且如果文件夹 Y 中已经存在该名称的文件，则该文件不会被覆盖，而是新文件的后缀为“-复制” , '- Copy (2)' 等 - 本质上是重新创建用于在文件夹中复制和粘贴相同文件的手动过程。

我原以为会有一个功能可以让你做到这一点，但到目前为止我没有尝试过似乎符合确切要求：

  • Workbook.SaveAs提示用户一条消息，询问是否应该替换文件

  • Workbook.SaveCopyAs只是在没有提示的情况下覆盖文件

  • 该FileSystemObject.CopyFile方法有一个“覆盖”参数，但是如果设置为 false 并且文件已经存在，这只是错误，这是根据Microsoft 网站的预期行为

创建一个根据所选文件夹（.xls (1)、.xls (2) 等）中现有文件的数量递增的计数器并不难，但我希望可能有比这更直接的方法这个。

4

3 回答 3

1

该功能对我有用，但经过两个步骤。

步骤1 ：

进入 VBE 的菜单（工具 -> 参考），然后在“Microsoft Scripting Run-time”旁边打勾。

第2步 ：

编辑代码，因为它是：

If FileExists(strFilePath) = True Then
   'Set fl = FSO.GetFile(strFilePath)
   strNewFileName = strFilePathNoFileName & strFileNameNoExt & " (" & intCounter & ")." & strExtension
   Do
       blnNotFound = FileExists(strNewFileName)
       If blnNotFound Then intCounter = intCounter + 1
   Loop Until Not blnNotFound
Else
     strNewFileName = strFilePath
End If

我猜你必须在循环中插入一行来更新新文件名，以便检查是否存在。所以新的代码应该是：

   Do
       blnNotFound = FileExists(strNewFileName)
       If blnNotFound Then intCounter = intCounter + 1
       ' HERE :
       strNewFileName = fl.ParentFolder & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension

   Loop Until Not blnNotFound

干得好，谢谢。

于 2018-03-18T23:03:02.697 回答
0

可能是这样的？您需要在它周围放置一个包装器，显示文件另存为对话框，然后在选定的文件路径上运行它。

Public Function CUSTOM_SAVECOPYAS(strFilePath As String)

Dim FSO As Scripting.FileSystemObject
Dim fl As Scripting.File
Dim intCounter As Integer
Dim blnNotFound As Boolean
Dim arrSplit As Variant
Dim strNewFileName As String
Dim strFileName As String
Dim strFileNameNoExt As String
Dim strExtension As String

arrSplit = Split(strFilePath, "\")

strFileName = arrSplit(UBound(arrSplit))
strFileNameNoExt = Split(strFileName, ".")(0)
strExtension = Split(strFileName, ".")(1)

Set FSO = New Scripting.FileSystemObject

intCounter = 1

If FSO.FileExists(strFilePath) Then
    Set fl = FSO.GetFile(strFilePath)
    strNewFileName = fl.Path & "\" & strFileNameNoExt & " (" & intCounter & ")." & strExtension
    Do
        blnNotFound = Not FSO.FileExists(strNewFileName)
        If Not blnNotFound Then intCounter = intCounter + 1
    Loop Until blnNotFound
Else
      strNewFileName = strFilePath    
End If

ThisWorkbook.SaveCopyAs strNewFileName
set fso=nothing
set fl =nothing

End Function
于 2016-11-14T10:14:14.307 回答
0

我没有找到任何直接的方法。下面的代码将给出所需的结果。由于 fso 对象对我不起作用，因此对之前的帖子进行了略微修改。

Public Function CUSTOM_SAVECOPYAS_FILENAME(strFilePath As String) As String
Dim intCounter As Integer
Dim blnNotFound As Boolean
Dim arrSplit As Variant
Dim strNewFileName As String
Dim strFileName As String
Dim strFileNameNoExt As String
Dim strExtension As String
Dim pos As Integer 
Dim strFilePathNoFileName  As String
arrSplit = Split(strFilePath, "\")

pos = InStrRev(strFilePath, "\")
strFilePathNoFileName = Left(strFilePath, pos)

strFileName = arrSplit(UBound(arrSplit))
strFileNameNoExt = Split(strFileName, ".")(0)
strExtension = Split(strFileName, ".")(1)


intCounter = 1

If FileExists(strFilePath) = True Then
    'Set fl = FSO.GetFile(strFilePath)
    strNewFileName = strFilePathNoFileName & strFileNameNoExt & " (" & intCounter & ")." & strExtension
    Do
        blnNotFound = FileExists(strNewFileName)
        If blnNotFound Then intCounter = intCounter + 1
    Loop Until Not blnNotFound
Else
      strNewFileName = strFilePath
End If

'This function will return file path to main function where you save the file
CUSTOM_SAVECOPYAS_FILENAME = strNewFileName

End Function

Public Function FileExists(ByVal path_ As String) As Boolean
FileExists = (Len(Dir(path_)) > 0)
End Function

'main
Sub main()
'.......
str_fileName = "C:/temp/test.xlsx"
str_newFileName = CUSTOM_SAVECOPYAS_FILENAME(str_fileName)

Application.DisplayAlerts = False
NewWb.SaveAs str_newFileName
NewWb.Close
Application.DisplayAlerts = True
End Sub
于 2018-01-30T11:26:34.717 回答