[發問] Excel檔案資料更新提示

本帖最後由 li918272002 於 2012-10-9 17:11 編輯

大家好，剛接觸VBA不久，網路上找了好多文章,也在此爬了很多文還是不知該怎麼完成我想要的功能。可否請教各位大師!!

我想要做一個功能,可以按下一個按鈕，自動去檢查資料夾內所有Excel檔案裡是否有更新資料,如果有顯示出有幾筆更新資料!!
不曉得能夠做到嗎？想了好久,還是做不出來。

麻煩大家幫個忙,謝謝。

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 14
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2024-11-6

2^#

發表於 2012-10-10 22:19 | 只看該作者

回復 1# li918272002
我能想到的有兩種方法:
1. 每個Excel檔案中作資料異動時就將相關資料寫到一個檔案中,需要時再去該檔案查詢.
優點是要存什麼資料自己可以決定
缺點是一切都要自己來做

2. 利用 Excel 的追蹤修訂功能 (因為我沒用過, 所以只能告知在哪可看到, 至於功能就要你自己測試囉)
工具->追蹤修訂->標示修訂處 (我使用 Excel 2003 版, 若是不同版本需要你自己再找一下被微軟搬到哪裡去了)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2012-10-13 15:25 | 只看該作者

本帖最後由 GBKEE 於 2012-10-13 15:33 編輯

回復 1# li918272002
先有紀錄,才可查看
新開檔案中, 複製下列三個模組, 存為增益集檔案, 載入此增益集檔案
爾後Excel中開啟已存檔的檔案可存下修改記錄

test.rar (26.17 KB)

插入表單(名稱 UserForm1 )的程式碼須有控制項 ComboBox1,ListBox1,ListBox2

'插入一表單(名稱 UserForm1 )的程式碼須有控制項 ComboBox1,ListBox1,ListBox2
Option Explicit
Dim xlFile As String
Private Sub ComboBox1_Change()
If ComboBox1.ListIndex > -1 Then
讀取追蹤檔
Else
ListBox1.Clear
End If
End Sub
Private Sub UserForm_Activate()
xlFile = ActiveWorkbook.Path & 追蹤檔
Caption = ActiveWorkbook.Path & 追蹤檔
If Dir(xlFile) = "" Then
Me.Hide
MsgBox ActiveWorkbook.Path & " 沒有變更的資料追蹤檔 "
Unload Me
Else
表單設定
End If
End Sub
Private Sub 表單設定()
Dim E As String
Top = 66.95
Left = 165.75
Height = 343.85
Width = 552.5
With ListBox1
.Top = 58.9
.Left = 17.65
.Height = 247.5
.Width = 507.45
.ColumnCount = 4
.ColumnWidths = "90,130,130,130"
.Font.Size = 12
End With
With ListBox2
.Top = 35.35
.Left = 17.65
.Height = 21.95
.Width = 507.5
.ColumnCount = 4
.ColumnWidths = "90,130,130,130"
.TextAlign = fmTextAlignCenter
.Font.Size = 16
End With
With ComboBox1
.Top = 11.8
.Left = 17.65
.Height = 15.05
.Width = 94.3
E = Dir(ActiveWorkbook.Path & "\*.XLS")
Do While E <> ""
If E <> ThisWorkbook.Name Then
.AddItem E
End If
E = Dir
Loop
.Value = ActiveWorkbook.Name
End With
End Sub
Private Sub 讀取追蹤檔()
Dim fs As Object, xlWord As Variant, I, E
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xlFile, 1, False)
xlWord = fs.readall
fs.Close
xlWord = Split(xlWord, Chr(10))
With ListBox2
.Clear
.AddItem
For E = 0 To .ColumnCount - 1
.List(.ListCount - 1, E) = Split(xlWord(0), ",")(E)
Next
End With
With ListBox1
.Clear
For I = 1 To UBound(xlWord) - 1
If InStr(xlWord(I), ComboBox1 & "]") Then
.AddItem
For E = 0 To .ColumnCount - 1
.List(.ListCount - 1, E) = Split(xlWord(I), ",")(E)
Next
End If
Next
End With
End Sub

複製代碼

插入一般模組 (名稱為 Module1 ) 的程式碼

'插入一般模組 (名稱為 Module1 ) 的程式碼
Option Explicit
Public Const 追蹤檔 = "\資料紀錄檔.TXT"
Public Ar(), xlId As CommandBarControl
Dim My_App As New Class1
Private Sub AUTO_CLOSE()
Application.CommandBars.ActiveMenuBar.Reset
End Sub
Private Sub AUTO_Open()
物件設定
新增指令
End Sub
Private Sub 物件設定()
Set My_App.APP = Application
End Sub
Private Sub 新增指令()
With Application.CommandBars.ActiveMenuBar
.Reset '重設功能表
With .Controls.add(10, , , , True) 'msoControlPopup
.Caption = "追蹤指令(&P)"
.TooltipText = "按 Alt + P"
Set xlId = .Controls.add(1) 'msoControlButton
With xlId
.Caption = "資料紀錄檔(&C)"
.OnAction = "追蹤指令"
.TooltipText = "按 Alt + C"
End With
With .Controls.add(1) 'msoControlButton
.Caption = "指令重設(&R)"
.OnAction = "AUTO_Open"
.TooltipText = "按 Alt + R"
End With
End With
End With
MakeAr
End Sub
Sub 追蹤指令()
UserForm1.Show
End Sub
Private Sub MakeAr() '取得工作表資料
Dim ArCell As String, Msg As Boolean
If Workbooks.Count = 0 Then
Msg = True
ElseIf ActiveWorkbook.Name = ThisWorkbook.Name Or ActiveWorkbook.Path = "" Then
Msg = True
ElseIf Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
Msg = True
End If
If Msg = True Then
xlId.Enabled = False '停止資料紀錄檔
Exit Sub
Else
xlId.Enabled = True '恢復資料紀錄檔
End If
ArCell = Range("A1:" & Cells.SpecialCells(xlCellTypeLastCell).Address).Address
On Error Resume Next
Ar = Application.Transpose(Range(ArCell).Value)
If Err.Number > 0 Then
ReDim Ar(1, 1)
Err.Clear
End If
End Sub

複製代碼

插入物件類別模組(名稱 Class1 ) 的程式碼

'插入物件類別模組(名稱 Class1 ) 的程式碼
Option Explicit
Public WithEvents APP As Application
Private Sub APP_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim xlErr As Integer, xlUsed As String
If ActiveWorkbook.Name = ThisWorkbook.Name Then Exit Sub
If ActiveWorkbook.Path = "" Then
MsgBox ActiveWorkbook.Name & " 未存檔請先存檔 !"
Exit Sub
End If
xlUsed = Application.UserName
On Error GoTo R
If Target(1).Row <= UBound(Ar, 2) And Target(1).Column <= UBound(Ar, 1) And Ar(Target(1).Column, Target(1).Row) <> "" Then
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Ar(Target.Column, Target(1).Row) & "," & Target(1).Value & "," & Application.UserName
Else
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & ",," & Target(1) & " ," & Application.UserName
End If
R:
xlErr = Err.Number
Run "Module1.MakeAr" 'MakeAr
If xlErr <> 0 Then
If Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Target(1) & ", ," & Application.UserName
xlId.Enabled = True
Else
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Ar(Target.Column, Target(1).Row) & ", ," & Application.UserName
End If
End If
Err.Clear
Sh.Parent.Save
End Sub
Private Sub APP_SheetActivate(ByVal Sh As Object)
Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub APP_WorkbookActivate(ByVal Wb As Workbook)
Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub 紀錄追蹤(xlWord As String) '紀錄變更的資料
Dim fs As Object, xltxt As String, xlFile As String
xlFile = ActiveWorkbook.Path & 追蹤檔
xltxt = Dir(xlFile)
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xlFile, 8, True)
If xltxt = "" Then
fs.WriteLINE "日期,位置,原本,變更,修改者"
End If
fs.WriteLINE xlWord
fs.Close
End Sub
Private Sub APP_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
If Wb.Name <> ThisWorkbook.Name Then Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub APP_WorkbookOpen(ByVal Wb As Workbook)
Run "Module1.MakeAr" 'MakeAr
End Sub