新建excel，复制内容张贴，重新命名并另存为相关问题

lin0527

请大师，有空帮我看看，我自已写代码没有写出来
实现功能
1：sheet1复制
2：新建excel，并张贴sheet1内容，保留格式
3：对新建excel重新命名，命名规则《“采购单”+当前日期+“01”序列号》
        《同时也要查找一下，保存地址里有没有同样名称，如果有，序号号就递增》这个功能实现更新，不能
         实   现也没有关系》
4：将新建excel另存为桌面，保存关闭

ykcbf1100

参与一下。。。

1. Sub test()
   
2.     Dim filename As String
   
3.     Dim currentdate As String
   
4.     Dim path, name As String
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
8.     Set d = CreateObject("Scripting.Dictionary")
   
9.     Sheet1.Copy
   
10.     Set wb = ActiveWorkbook
    
11.     currentdate = Format(Now(), "YYYYMMDD")
    
12.     path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
13.     For Each f In Fso.GetFolder(path).Files
    
14.         If f.name Like "*.xls*" Then
    
15.             fn = Fso.GetBaseName(f)
    
16.             fn1 = Left(fn, Len(fn) - 3)
    
17.             d(fn1) = Val(Right(fn, 2))
    
18.         End If
    
19.     Next f
    
20.     name = "采购单" & currentdate
    
21.     If Not d.exists(name) Then
    
22.         st = "01"
    
23.     Else
    
24.         m = d(name)
    
25.         st = Format(m + 1, "00")
    
26.     End If
    
27.     wb.SaveAs path & "" & name & "-" & st
    
28.     wb.Close
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

ykcbf1100

原代码基础上修改的，供参考。。。

lin0527

ykcbf1100 发表于 2023-12-29 19:55
原代码基础上修改的，供参考。。。

你好，刚试了一下，可以了，非常感谢
代码里有检查保存桌面是否有重名，如果有序号叠加，我连续保存2次，第1次OK，保存第2次的时候就保存不进去（因为有重复的文件名）没有序号叠加。


Sub test()
    Dim filename As String
    Dim currentdate As String
    Dim path, name As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.Dictionary")
    Sheet1.Copy
    Set wb = ActiveWorkbook
    currentdate = Format(Now(), "YYYYMMDD")
    path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    For Each f In Fso.GetFolder(path).Files
        If f.name Like "*.xls*" Then
            fn = Fso.GetBaseName(f)
            d(fn) = fn
        End If
    Next f
    name = "采购单" & currentdate & "-01"
    If d.exists(name) Then
        m = Val(Right(d(s), 2))
        st = Format(m + 1, "00")
    Else
        st = "01"
    End If
    wb.SaveAs path & "\" & name & "-" & st
    wb.Close
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub