白话Excel函数公式 Office易学宝微视频教程合集(Excel+Word+PPT)
笨办法学VBA(从入门到精通) 高效办公必会的Office实战技巧
财务总监的Excel私房课 Excel数据透视表实战秘技
Excel图表神技
查看: 1741|回复: 3

VBA实战演练系列之1--时间更新提示表(优秀解法有适当奖励)

[复制链接]
发表于 2012-3-6 23:07:57 | 显示全部楼层 |阅读模式
本帖最后由 hustnzj 于 2012-3-7 07:06 编辑

这个是wmhlwx同学在QQ群上提的问题:

各分支工作簿中指定表合并,并且有表改变,提示是否自动更新
http://club.excelhome.net/thread-833398-1-1.html

给出自己的解法及附件,大家可以参考。欢迎指正。

给出优秀解法有适当的奖励!





各分支工作簿中指定表合并,并且有表改变,提示是否自动更新.rar

46 KB, 下载次数: 32

回复

使用道具 举报

发表于 2012-3-7 10:46:52 | 显示全部楼层
回来我用WORKBOOK自己的属性列表写一个。
回复 支持 反对

使用道具 举报

发表于 2012-3-7 21:48:56 | 显示全部楼层
本帖最后由 wmhlwx 于 2012-3-7 21:57 编辑
  1. Private Sub Getalldate()
  2. With Worksheets("Record")
  3.     ReDim arr(1 To 10, 1 To 2)
  4.   [A1].Resize(10, 2).ClearContents
  5.         myPath = ThisWorkbook.Path & ""
  6.         myFile = Dir(myPath & "*.xls*")
  7.         Do While myFile <> ""
  8.             If myFile <> ThisWorkbook.Name Then
  9.                 Set OPWS = GetObject(myPath & myFile)
  10.                 i = i + 1
  11.                 arr(i, 1) = myFile
  12.                 arr(i, 2) = OPWS.BuiltinDocumentProperties(12).Value
  13.                 OPWS.Close False
  14.             End If
  15.             myFile = Dir
  16.         Loop
  17.     [A1].Resize(10, 2) = arr
  18.     End With
  19. End Sub
复制代码
先拿出取得工作簿修改时间的代码,跟hustnzj的不一样哦。

评分

参与人数 1登攀 +5 收起 理由
hustnzj + 5 不错!值得鼓励!

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2012-3-7 22:01:56 | 显示全部楼层
本帖最后由 wmhlwx 于 2012-3-7 22:41 编辑
  1. 删掉,发终稿。
复制代码
这个我当时写好了,正式情况是A列到AE列,表格是8个表格,我老婆公司8个不同专业的,有的是03格式的XLS,有的是07格式的XLSX。暂时用M列,没啥关系。

这个参考大虾的思路。  其实当时我就是懒,想找现成的,结果没人写。

Private Sub Workbook_Open()
Call Compare
End Sub


Sub Compare()

'取得日期数组
      ReDim arr(1 To 10, 1 To 2)
      myPath = ThisWorkbook.Path & "\"
        myFile = Dir(myPath & "*.xls*")
        Do While myFile <> ""
            If myFile <> ThisWorkbook.Name Then
                Set OPWS = GetObject(myPath & myFile)
                i = i + 1
                arr(i, 1) = myFile
                arr(i, 2) = OPWS.BuiltinDocumentProperties(12).Value
                OPWS.Close False
            End If
            myFile = Dir
        Loop

'判断是否建立文件属性档案
'如果没有就建立
    If Worksheets("Record").[A1] = "" Then
    Worksheets("Record").[A1].Resize(10, 2).ClearContents
    Worksheets("Record").[A1].Resize(10, 2) = arr
    Call Getalltable
    Else
'否则就逐个比较
        brr = Worksheets("Record").[A1].Resize(10, 2)
        For i = 1 To 10
            For j = 1 To 2
                If arr(i, j) <> brr(i, j) Then
                    If MsgBox("发现改变是否更新?", 4) = vbYes Then
                        Worksheets("Record").[A1].Resize(10, 2) = arr
                        Call Getalltable
                        Exit Sub
                    Else: End
                    End If
                End If
            Next j
        Next i
'如果都相同,加上是否强制更新。
        If MsgBox("未发现改变是否强制更新?", 4) = vbYes Then Call Getalltable
    End If
End Sub



Sub Getalltable()
'clear
    OROW = Worksheets("list").Range("A60000").End(xlUp).Row + 1
    Range("A2:M" & OROW).ClearContents
'copy
  myPath = ThisWorkbook.Path & "\"
  myFile = Dir(myPath & "*.xls")
  Do While myFile <> ""
  If myFile <> ThisWorkbook.Name Then
    Set OPWS = GetObject(myPath & myFile)
    sRow = OPWS.Sheets("list").Range("A60000").End(xlUp).Row
    OROW = Range("A60000").End(xlUp).Row + 1
    OPWS.Sheets("list").Range("A2:M" & sRow).Copy Worksheets("list").Range("A" & OROW)
     OPWS.Close False
  End If
  myFile = Dir
  Loop
End Sub

All.rar

39.03 KB, 下载次数: 13

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

快速回复 返回顶部 返回列表