2009年5月15日 星期五

Excel VBA 在儲存前捉取別 Excel 檔 sheet 作更新動作

'存檔前執行
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)


Dim ofile, ff, readfile
Dim theShell As Object

'指定路徑和檔名
DataPath = "C:\XXXX\YYYYY\"
DataFile = "ZZZZZ.xls"

'確認是否有此檔案
With Application.FileSearch
.NewSearch
.LookIn = DataPath
.Filename = DataFile
If .Execute() > 0 Then ff = .FoundFiles.Count
End With


'如果有檔案則開啟此檔案,如果無則跳出 File 對話窗,選取檔案
If ff > 0 Then

' Open( 檔名 , 不做 Update link , 唯讀 )
Set ofile = Workbooks.Open( DataPath & DataFile , 0, True)

Else
'如果找不到檔案,開啟 File 對話窗選取檔案
MsgBox DataPath & DataFile & "檔案不存在,請重新選取路徑。"
Set readfile = Application.FileDialog(msoFileDialogFilePicker)
Dim v As Variant
With readfile
.Filters.Clear
.InitialFileName = DataPath
.InitialView = msoFileDialogViewDetails
.Filters.Add "All Excel Files", "*.xls"
.AllowMultiSelect = False
If .Show Then
v = .SelectedItems.Item(1)
End If
End With

'如果沒有選擇檔案直接結束。
If v Is Nothing Then
Set ofile = Workbooks.Open(v, 0, True)

Else
MsgBox "檔案不存在,請確認。"
End
End If
End If


Cells.Select
Selection.Copy


Dim ck, ckr As Boolean

ck = False

'確認本地檔案中是否有 Index sheet ,如果有需 Delete Index sheet
For Each element In Me.Worksheets

If element.Name = "Index" Then
' Disable 詢問
Application.DisplayAlerts = False
Me.Worksheets("Index").Delete
Application.DisplayAlerts = True
ck = True
Exit For

End If

Next


ck = False

'由來源檔插入 Index Fig sheet 於 Content sheet 之後,並將 Index Fig sheet 改名為 Index sheet
For Each element In ofile.Worksheets

If element.Name = "Index Fig" Then
ofile.Worksheets("Index Fig").Copy after:=Me.Worksheets("Content")
Me.Worksheets("Index Fig").Name = "Index"
ck = True
Exit For
End If

Next

'如果 ck = False 表 來源檔無 Index Fig sheet
If ck = False Then
MsgBox "ZZZZZ.xls 中的 [ Index Fig ] sheet 不存在請確認"
ofile.Close (False)
End

End If



ofile.Close (False)





End Sub

[Excel]如何創建自定義函數

在 Excel 內建函式中找不到自已想要的函式怎麼辦?事實上我們可以自已建一個,以下是一個簡單的Excel自定義函數示例,用於將民國年轉為西元: Function 民國轉西元(x As Double) As Double     民國轉西元 = x + 1911 End Func...