[µo°Ý] ¤u§@ªí¥t¦s®É, ¨ú®ø­«ÂЦsÀÉ¥X¿ù

missbb

¤U¦CCODE, §Ú±N¤u§@ªí¥t¦s·sÀÉ, ¦ý·í¦sÀɮɦ³¬Û¦P¦WºÙªºÀÉ®×, §Ú¿ï¾Ü¤£¦sÀÉ, µ{¦¡¤´·|¦sÀɦbACTIVE WORKBOOKªºPATH, ©M¥X²{¤w"¤w¸g·s¼WÀÉ®×".

§Ú·Q¦pªG¿ï¾Ü¤£­«ÂЦsÀÉ, ª½±µ°h¥Xµ{¦¡, Åã¥Ü°T®§"¤w¸g¨ú®ø­«ÂЦsÀÉ", ¬O¦p¦ó§ïCODE©O? ÁÂÁÂ! TEST FILE SAVE.zip (18.08 KB)

¤U¸ü¦¸¼Æ: 2

2024-1-7 23:09

1. Sub saveactivesheet2()
   
2. '¥Ø«e¤u§@ªí¥t¦s«ü©w¦ì¸m©MÀÉ«ö¦WºÙ
   
3. 
   
4. Application.ScreenUpdating = False
   
5. 'Application.DisplayAlerts = False
   
6. 
   
7. Dim currentworkbook As Workbook
   
8. Dim newworkbook As Workbook
   
9. Dim currentworksheet As Worksheet
   
10. Dim newworkbookname As String
    
11. Dim fPath As String
    
12. 
    
13. Set currentworkbook = ThisWorkbook
    
14. Set currentworksheet = ActiveSheet
    
15. 
    
16. newworkbookname = ActiveSheet.Range("S2").Value
    
17. fPath = ActiveSheet.Range("S3").Value
    
18. 
    
19. Set newworkbook = Workbooks.Add
    
20. currentworksheet.Copy before:=newworkbook.Sheets(1)
    
21. 
    
22. Range("A1:G100").Select
    
23.     Selection.Copy
    
24.     Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    
25.         xlNone, SkipBlanks:=False, Transpose:=False
    
26.     Columns("H:Y").Select
    
27.     Application.CutCopyMode = False
    
28.     Selection.Delete Shift:=xlToLeft
    
29.     Range("A1").Select
    
30.     ActiveWorkbook.Save
    
31. 
    
32. On Error Resume Next
    
33. 
    
34. newworkbook.SaveAs Filename:=fPath & "\" & newworkbookname
    
35. 
    
36. newworkbook.Close
    
37. 
    
38. 'Since nothing changed on sheet, provide feedback to user
    
39.     MsgBox "¤w¸g·s¼WÀÉ®×"
    
40. 
    
41. 
    
42. 
    
43. 
    
44. End Sub
    
45. 
    
46.    
    
47.    

½Æ»s¥N½X

Andy2483

¦^´_ 1# missbb


     If Dir(fPath & "\" & newworkbookname) <> "" Then Msgbox "¤w¸g¨ú®ø­«ÂЦsÀÉ"¡G Exit Sub

missbb

¦^´_ 2# Andy2483
·Q½Ð¸û§A·s¼WªºCODEÀ³©ñ¦b§ÚªºCODE¨º¤@­Ó¦ì¸m? §Ú©ñ¦bON ERROR RESUME NEXT¤§¤U, §Y¨Ï¤£¬Ó½Æ¦sÀÉ, ³£¬O¥X²{ MsgBox "¤w¸g·s¼WÀÉ®×".

ÁÂÁ¸ѵª:D

Andy2483

¦^´_ 3# missbb


    ÁÂÁ½׾Â,ÁÂÁ«e½ú¦^´_
¥H¤U¬O«Øij¤è®×,½Ð«e½ú°Ñ¦Ò

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim filename As String, fPath As String
filename = [S2]: fPath = [S3]: If Dir(fPath, vbDirectory) = "" Then MkDir fPath
If Dir(fPath & "\" & filename & ".xlsx") <> "" Then
   MsgBox "«ü©wªº " & filename & ".xlsx ¤w¸g¦s¦b! ¨S¦³°õ¦æ¦sÀÉ": Exit Sub
End If
ActiveSheet.Copy
[A1:G100].Value = [A1:G100].Value
[H:Y].Delete: [A1].Select
ActiveWorkbook.SaveAs filename:=fPath & "\" & filename & ".xlsx"
ActiveWorkbook.Close
MsgBox "¤w¸g·s¼WÀÉ®×": ThisWorkbook.Activate
End Sub

missbb

ÁÂÁ¡A±zªº«ü¾É¤Q¤À¨ü¥Î