GBKEE

¦^´_ 6# bridetobe
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Sub Ū¥X()
   
3.     Dim a_date, Rng(1 To 2) As Range
   
4.     Application.Calculation = xlCalculationManual  '¤â°Ê­pºâ
   
5.     Application.StatusBar = False
   
6.     With Sheets("¾Þ§@")
   
7.         Set Rng(1) = .[A2:F2]
   
8.         Set Rng(2) = .Cells(1, .Columns.Count)
   
9.        .Range(Rng(1)(2, 1), Rng(1).End(xlDown)).Resize(, 7) = ""
   
10.         .[B1].Value = InputBox("¿é¤J¤é´Á(¨Ò2014/7/1):", , "2014/7/1")
    
11.         Rng(2) = "¤é´Á"
    
12.         Rng(2).Offset(1) = .[B1]
    
13.         'AdvancedFilter ¶i¶¥¿z¿ï
    
14.       '¶i¶¥¿z¿ï:ªº·Ç«h½d³ò -> Rng(2).Resize(2)
    
15.       Sheets("¦s³f¸ê®Æ").UsedRange.AdvancedFilter xlFilterCopy, Rng(2).Resize(2), Rng(1)
    
16.         Rng(2).EntireColumn = ""
    
17.         If Rng(1).End(xlDown).Row <> .Rows.Count Then
    
18.             Set Rng(2) = Rng(1).Cells(2, 1)
    
19.             Do While Rng(2) <> ""
    
20.                 Rng(2).Cells(1, "G") = ¤W¤@­Ó¤p­p(.[B1], Rng(2).Text) - Rng(2).Cells(1, "F")
    
21.                 If Rng(2).Cells(1, "G") < 0 Then Rng(2).Cells(1, "G") = 0
    
22.                  Set Rng(2) = Rng(2).Cells(2)
    
23.             Loop
    
24.             MsgBox "Ok"            
    
25.         Else
    
26.             MsgBox "¨S¦³¸ê®Æ"
    
27.         End If
    
28.     End With
    
29.    ' Application.Calculation = xlAutomatic            '¦Û°Ê­pºâ
    
30.     '¦Û°Ê¿z¿ï«á·|¦³¤u§@ªí­«ºâªº°Ê§@,µ{¦¡·|µ¥­Ô­«ºâ§¹²¦,¦AÄ~Äò°õ¦æ¤U¥h.
    
31. End Sub
    
32. 'AutoFilter: ¦Û°Ê¿z¿ï
    
33. Private Function ¤W¤@­Ó¤p­p(¤é´Á As String, «~¦W As String) As Integer
    
34.     Dim Rng As Range
    
35.     With Sheets("¦s³f¸ê®Æ").UsedRange
    
36.         '¦Û°Ê­pºâ:·í¦Û°Ê¿z¿ï«á·|¦³¤u§@ªí­«ºâªº°Ê§@,¼vÅTµ{¦¡°õ¦æªº³t«×
    
37.         '¦Û°Ê¿z¿ï «ü©wÄæ¦ì,·Ç«h
    
38.         .AutoFilter 1, ">" & ¤é´Á
    
39.         .AutoFilter 2, "=" & «~¦W        
    
40.         Set Rng = .SpecialCells(xlCellTypeVisible)
    
41.         If Rng.Areas(1).Rows.Count > 1 Then
    
42.             ¤W¤@­Ó¤p­p = Rng.Areas(1).Cells(2, "g")
    
43.         Else
    
44.             ¤W¤@­Ó¤p­p = Rng.Areas(2).Cells(1, "g")
    
45.         End If
    
46.     End With
    
47. End Function

½Æ»s¥N½X