- 帖子
- 97
- 主題
- 33
- 精華
- 0
- 積分
- 129
- 點名
- 0
- 作業系統
- Win 7
- 軟體版本
- office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2019-5-7
- 最後登錄
- 2022-8-25
|
5#
發表於 2019-6-18 16:38
| 只看該作者
回復 1# s13030029
已解決~~
提供程式碼給大家參考- Sub 匯出製程記錄表()
- Titlename = ThisWorkbook.Sheets("製程檢查記錄表").Range("H4").Value
- Dim ylFolder As String
- ylFolder = ThisWorkbook.Path & "\" & Titlename & "記錄表" '指定資料夾
- If Dir(ylFolder, vbDirectory) = "" Then MkDir ylFolder
-
- Dim stFileName As String
- Dim xPath As String
- xPath = Application.ActiveWorkbook.Path
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
-
- With ActiveSheet
- .Copy
- ActiveSheet.DrawingObjects.Delete
- XX:
- X = InputBox("請輸入檔名!!", "另存新檔", Titlename & " " & "檢驗報告")
- stFileName = ylFolder & "\" & X & ".xls"
- If X <> "" Then
- If Dir(stFileName) <> "" Then
- MsgBox "已有相同檔名！"
- GoTo XX
- Else
- Application.ActiveWorkbook.SaveAs Filename:=ylFolder & "\" & X, _
- FileFormat:=xlExcel8
- MsgBox "儲存成功!"
- End If
- ElseIf X = "" Then
- MsgBox "已取消儲存!!!"
- End If
- Application.ErrorCheckingOptions.BackgroundChecking = False
- Application.ActiveWorkbook.Close False
- End With
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
-
- End Sub
|
|
