VBA无所不能，判断判断同目录下文件最后修改（创建）时间，然后进行相关操作

sogo777

1. Private Sub CommandButton1_Click()
   
2. Dim wbook As Workbook
   
3. Dim xx()
   
4. Application.ScreenUpdating = False
   
5. p = 1
   
6. lastrow = [d65535].End(xlUp).Row
   
7. If lastrow > 1 Then Range("a2:g" & lastrow).ClearContents
   
8. lj = ThisWorkbook.Path
   
9. wbn = ThisWorkbook.Name
   
10.   dirna = Dir(lj & "\*.xls")
    
11.    Do While dirna <> ""
    
12.     temp = lj & "" & dirna
    
13.     If dirna <> wbn Then
    
14.      If WorkbookOpen(CStr(dirna)) Then
    
15.       Set wbook = Workbooks(CStr(dirna))
    
16.      Else
    
17.       Set wbook = Workbooks.Open(temp)
    
18.      End If
    
19.      For i = 1 To wbook.Sheets.Count
    
20.       With wbook.Sheets(i)
    
21.        shtn = .Name
    
22.        pm = .Cells(4, 1)
    
23.        lr = .[a65535].End(xlUp).Row
    
24.        arr = .Range("a2:e" & lr)
    
25.        If lr = 9 Then
    
26.         ReDim Preserve xx(1 To 7, 1 To p)
    
27.         '文件名  品名    工作表名称  B列 C列 D列 E列
    
28.         xx(1, p) = dirna
    
29.         xx(2, p) = pm
    
30.         xx(3, p) = shtn
    
31.         xx(4, p) = arr(2, 2)
    
32.         xx(5, p) = arr(2, 3)
    
33.         xx(6, p) = arr(2, 4)
    
34.         xx(7, p) = arr(2, 5)
    
35.         p = p + 1
    
36.        ElseIf lr > 9 Then
    
37.         ReDim Preserve xx(1 To 7, 1 To p)
    
38.         '文件名  品名    工作表名称  B列 C列 D列 E列
    
39.         xx(1, p) = dirna
    
40.         xx(2, p) = pm
    
41.         xx(3, p) = shtn
    
42.         xx(4, p) = arr(2, 2)
    
43.         xx(5, p) = arr(2, 3)
    
44.         xx(6, p) = arr(2, 4)
    
45.         xx(7, p) = arr(2, 5)
    
46.         p = p + 1
    
47.         For j = 3 To UBound(arr)
    
48.          ReDim Preserve xx(1 To 7, 1 To p)
    
49.          xx(4, p) = arr(j, 2)
    
50.          xx(5, p) = arr(j, 3)
    
51.          xx(6, p) = arr(j, 4)
    
52.          xx(7, p) = arr(j, 5)
    
53.          p = p + 1
    
54.         Next
    
55.        End If
    
56.       End With
    
57.      Next
    
58.      wbook.Close
    
59.     End If
    
60.     dirna = Dir
    
61.    Loop
    
62. 
    
63. 
    
64. If p > 1 Then Range("a2:g" & p) = Application.Transpose(xx)
    
65. 
    
66. Application.ScreenUpdating = True
    
67. MsgBox "   提取完毕 !~", , "提示"
    
68. End Sub

复制代码

各位老师好，这个是坛子里一位老师的代码，我试了一下，完美运行，现在我有个想法，能否在遍历的过程中判断一下文件日期，如果文件创建日期是今天 则提取这个文件数据，如果文件创建或者修改日期不是今天，则提示 xx文件“为过期文件”忽略不计，请问我这个想法是否能够实现。

liulang0808

http://club.excelhome.net/blog-238368-1693.html
看看这个，能不能帮到你

sogo777

liulang0808 发表于 2014-4-30 16:01
http://club.excelhome.net/blog-238368-1693.html
看看这个，能不能帮到你

多谢，我试试

sogo777

没成功，您在帮忙看看

liulang0808

sogo777 发表于 2014-4-30 16:04
多谢，我试试

里面有关fso的使用，下方有具体使用案例的

sogo777

多谢。继续寻求解决语句，哪位能够指点一二？