[已解决]请帮忙修改下，复制到DATA文件夹后自动根据系统日期，当前系统时间重新命名

excel010

请帮忙修改下，
执行复制【工作记录3】到D盘【DATA文件夹】后，根据当前系统日期，当前系统时间，重新命名。

例如，文件名是（工作记录3），当前日期是（2016-05-09），系统时间是（08:08:08）
那么复制好到D盘后，D盘中的【工作记录3】的名字就是：工作记录3-2016-05-09-08:08:08

工作记录3.rar (14.27 KB, 下载次数: 5)

2016-5-8 08:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2016-5-8 14:23

'备份
Private Sub CommandButton1_Click()
    Dim p As String, f As String

    ThisWorkbook.Save
    p = "D:\DATA\"
    f = ThisWorkbook.FullName

    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(p) = False Then .CreateFolder p
        .CopyFile f, p
        Call rename(p, .GetBaseName(f), .GetExtensionName(f))
    End With
End Sub

'更名
Sub rename(p, f, e)
    Dim OldName, NewName
    OldName = p & f & "." & e
    NewName = p & f & Format(Now, "-yyyymmhh-hhmmss.") & e
    Name OldName As NewName    ' 更改文件名。
End Sub

工作记录4.rar (15.45 KB, 下载次数: 5)

2016-5-8 14:22 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

'备份
Private Sub CommandButton1_Click()
    Dim p As String, f As String

    ThisWorkbook.Save
    p = "D:\DATA\"
    f = ThisWorkbook.FullName

    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(p) = False Then .CreateFolder p
        .CopyFile f, p
        Call rename(p, .GetBaseName(f), .GetExtensionName(f))
    End With
End Sub

'更名
Sub rename(p, f, e)
    Dim OldName, NewName
    OldName = p & f & "." & e
    NewName = p & f & Format(Now, "-yyyymmhh-hhmmss.") & e
    Name OldName As NewName    ' 更改文件名。
End Sub

工作记录4.rar (15.45 KB, 下载次数: 5)

2016-5-8 14:22 上传

点击文件名下载附件