返回列表 上一主題 發帖

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

li918272002

帖子
1 
主題
1 
精華
0 
積分
7 
點名
0  
作業系統
WIIN7 
軟體版本
HOME 
閱讀權限
10 
註冊時間
2012-10-9 
最後登錄
2013-2-20 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2012-10-9 17:08 | 只看該作者

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

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

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

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

麻煩大家幫個忙,謝謝。
收藏 分享

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
5#
發表於 2012-10-15 14:00 | 只看該作者
Excel 2010
上方工具列 → 校閱 → 變更內

  多做多想多學習，少看少錯少迷途

  多做=多多練習，多多編寫。
  多想=想想為什麼人家程式要那樣寫，如果換成自己，又會怎寫。
  多學習=學習人家的發問並解答，學習人家的寫法

  少看=只看不做也枉然

TOP

hsiehth

帖子
5 
主題
0 
精華
0 
積分
9 
點名
0  
作業系統
Win7 
軟體版本
office2003 
閱讀權限
10 
性別
男 
註冊時間
2012-10-13 
最後登錄
2012-10-13 
4#
發表於 2012-10-13 16:37 | 只看該作者
原來還有這種方式
真是學到了

TOP

GBKEE

帖子
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
  1. '插入 一表單(名稱 UserForm1 )的程式碼   須有控制項 ComboBox1,ListBox1,ListBox2
  2. Option Explicit
  3. Dim xlFile As String
  4. Private Sub ComboBox1_Change()
  5.     If ComboBox1.ListIndex > -1 Then
  6.         讀取追蹤檔
  7.     Else
  8.         ListBox1.Clear
  9.     End If
  10. End Sub
  11. Private Sub UserForm_Activate()
  12.     xlFile = ActiveWorkbook.Path & 追蹤檔
  13.     Caption = ActiveWorkbook.Path & 追蹤檔
  14.     If Dir(xlFile) = "" Then
  15.         Me.Hide
  16.         MsgBox ActiveWorkbook.Path & " 沒有變更的資料 追蹤檔 "
  17.         Unload Me
  18.     Else
  19.         表單設定
  20.     End If
  21. End Sub
  22. Private Sub 表單設定()
  23.     Dim E As String
  24.     Top = 66.95
  25.     Left = 165.75
  26.     Height = 343.85
  27.     Width = 552.5
  28.     With ListBox1
  29.         .Top = 58.9
  30.         .Left = 17.65
  31.         .Height = 247.5
  32.         .Width = 507.45
  33.         .ColumnCount = 4
  34.         .ColumnWidths = "90,130,130,130"
  35.         .Font.Size = 12
  36.     End With
  37.     With ListBox2
  38.         .Top = 35.35
  39.         .Left = 17.65
  40.         .Height = 21.95
  41.         .Width = 507.5
  42.         .ColumnCount = 4
  43.         .ColumnWidths = "90,130,130,130"
  44.         .TextAlign = fmTextAlignCenter
  45.         .Font.Size = 16
  46.     End With
  47.     With ComboBox1
  48.         .Top = 11.8
  49.         .Left = 17.65
  50.         .Height = 15.05
  51.         .Width = 94.3
  52.         E = Dir(ActiveWorkbook.Path & "\*.XLS")
  53.         Do While E <> ""
  54.         If E <> ThisWorkbook.Name Then
  55.             .AddItem E
  56.         End If
  57.         E = Dir
  58.         Loop
  59.         .Value = ActiveWorkbook.Name
  60.     End With
  61. End Sub
  62. Private Sub 讀取追蹤檔()
  63.     Dim fs As Object, xlWord As Variant, I, E
  64.     Set fs = CreateObject("Scripting.FileSystemObject")
  65.     Set fs = fs.OpenTextFile(xlFile, 1, False)
  66.     xlWord = fs.readall
  67.     fs.Close
  68.     xlWord = Split(xlWord, Chr(10))
  69.     With ListBox2
  70.         .Clear
  71.         .AddItem
  72.         For E = 0 To .ColumnCount - 1
  73.             .List(.ListCount - 1, E) = Split(xlWord(0), ",")(E)
  74.         Next
  75.     End With
  76.     With ListBox1
  77.         .Clear
  78.         For I = 1 To UBound(xlWord) - 1
  79.             If InStr(xlWord(I), ComboBox1 & "]") Then
  80.                 .AddItem
  81.                 For E = 0 To .ColumnCount - 1
  82.                     .List(.ListCount - 1, E) = Split(xlWord(I), ",")(E)
  83.                 Next
  84.             End If
  85.         Next
  86.     End With
  87. End Sub
複製代碼
插入 一般模組 (名稱為  Module1 ) 的程式碼
  1. '插入 一般模組 (名稱為  Module1 ) 的程式碼
  2. Option Explicit
  3. Public Const 追蹤檔 = "\資料紀錄檔.TXT"
  4. Public Ar(), xlId As CommandBarControl
  5. Dim My_App As New Class1
  6. Private Sub AUTO_CLOSE()
  7.     Application.CommandBars.ActiveMenuBar.Reset
  8. End Sub
  9. Private Sub AUTO_Open()
  10.     物件設定
  11.     新增指令
  12. End Sub
  13. Private Sub 物件設定()
  14.     Set My_App.APP = Application
  15. End Sub
  16. Private Sub 新增指令()
  17.     With Application.CommandBars.ActiveMenuBar
  18.         .Reset                   '重設  功能表
  19.         With .Controls.add(10, , , , True) 'msoControlPopup
  20.             .Caption = "追蹤指令(&P)"
  21.             .TooltipText = "按 Alt + P"
  22.             Set xlId = .Controls.add(1)     'msoControlButton
  23.             With xlId
  24.                 .Caption = "資料紀錄檔(&C)"
  25.                 .OnAction = "追蹤指令"
  26.                 .TooltipText = "按 Alt + C"
  27.             End With
  28.             With .Controls.add(1)           'msoControlButton
  29.                 .Caption = "指令重設(&R)"
  30.                 .OnAction = "AUTO_Open"
  31.                 .TooltipText = "按 Alt + R"
  32.             End With
  33.         End With
  34.     End With
  35.     MakeAr
  36. End Sub
  37. Sub 追蹤指令()
  38.     UserForm1.Show
  39. End Sub
  40. Private Sub MakeAr()  '取得工作表資料
  41.     Dim ArCell As String, Msg As Boolean
  42.    If Workbooks.Count = 0 Then
  43.         Msg = True
  44.    ElseIf ActiveWorkbook.Name = ThisWorkbook.Name Or ActiveWorkbook.Path = "" Then
  45.         Msg = True
  46.    ElseIf Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
  47.         Msg = True
  48.     End If
  49.     If Msg = True Then
  50.         xlId.Enabled = False        '停止 資料紀錄檔
  51.         Exit Sub
  52.     Else
  53.         xlId.Enabled = True         '恢復 資料紀錄檔
  54.     End If
  55.     ArCell = Range("A1:" & Cells.SpecialCells(xlCellTypeLastCell).Address).Address
  56.     On Error Resume Next
  57.     Ar = Application.Transpose(Range(ArCell).Value)
  58.     If Err.Number > 0 Then
  59.         ReDim Ar(1, 1)
  60.         Err.Clear
  61.     End If
  62. End Sub
複製代碼
插入 物件類別模組(名稱 Class1 ) 的程式碼
  1. '插入 物件類別模組(名稱 Class1 ) 的程式碼
  2. Option Explicit
  3. Public WithEvents APP As Application
  4. Private Sub APP_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  5.     Dim xlErr As Integer, xlUsed As String
  6.     If ActiveWorkbook.Name = ThisWorkbook.Name Then Exit Sub
  7.     If ActiveWorkbook.Path = "" Then
  8.         MsgBox ActiveWorkbook.Name & "  未存檔 請先存檔 !"
  9.         Exit Sub
  10.     End If
  11.     xlUsed = Application.UserName
  12.     On Error GoTo R
  13.     If Target(1).Row <= UBound(Ar, 2) And Target(1).Column <= UBound(Ar, 1) And Ar(Target(1).Column, Target(1).Row) <> "" Then
  14.         紀錄追蹤 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
  15.     Else
  16.         紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & ",," & Target(1) & " ," & Application.UserName
  17.     End If
  18. R:
  19.     xlErr = Err.Number
  20.     Run "Module1.MakeAr" 'MakeAr
  21.     If xlErr <> 0 Then
  22.         If Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
  23.             紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Target(1) & ", ," & Application.UserName
  24.             xlId.Enabled = True
  25.         Else
  26.             紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Ar(Target.Column, Target(1).Row) & ", ," & Application.UserName
  27.         End If
  28.     End If
  29.     Err.Clear
  30.     Sh.Parent.Save
  31. End Sub
  32. Private Sub APP_SheetActivate(ByVal Sh As Object)
  33.     Run "Module1.MakeAr" 'MakeAr
  34. End Sub
  35. Private Sub APP_WorkbookActivate(ByVal Wb As Workbook)
  36.     Run "Module1.MakeAr" 'MakeAr
  37. End Sub
  38. Private Sub 紀錄追蹤(xlWord As String)     '紀錄變更的資料
  39.     Dim fs As Object, xltxt As String, xlFile As String
  40.     xlFile = ActiveWorkbook.Path & 追蹤檔
  41.     xltxt = Dir(xlFile)
  42.     Set fs = CreateObject("Scripting.FileSystemObject")
  43.     Set fs = fs.OpenTextFile(xlFile, 8, True)
  44.     If xltxt = "" Then
  45.     fs.WriteLINE "日期,位置,原本,變更,修改者"
  46.     End If
  47.     fs.WriteLINE xlWord
  48.     fs.Close
  49. End Sub
  50. Private Sub APP_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
  51. If Wb.Name <> ThisWorkbook.Name Then Run "Module1.MakeAr"   'MakeAr
  52. End Sub
  53. Private Sub APP_WorkbookOpen(ByVal Wb As Workbook)
  54. Run "Module1.MakeAr" 'MakeAr
  55. End Sub
複製代碼

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
1  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
2#
發表於 2012-10-10 22:19 | 只看該作者
回復 1# li918272002
我能想到的有兩種方法:
1. 每個Excel檔案中作資料異動時就將相關資料寫到一個檔案中,需要時再去該檔案查詢.
優點是要存什麼資料自己可以決定
缺點是一切都要自己來做

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

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
返回列表 上一主題