GBKEE

回復 2# cdkee
  9:16:000和13:31:000   這格式多一個0

GBKEE

回復 2# cdkee

1. Option Explicit
   
2. Sub Ex_Replace()   '修改 :000   為 :00
   
3.     With ActiveSheet.Range("B:B,K:K")
   
4.         .Replace ":000", ":00", xlPart
   
5.         .NumberFormatLocal = "h:mm:ss;@"
   
6.     End With
   
7. End Sub
   
8. Sub Ex()
   
9.     Dim xi As Date, Ea, Rng(1 To 3) As Range
   
10.     On Error Resume Next
    
11.     Application.ScreenUpdating = False
    
12.     With Sheet1
    
13.         .AutoFilterMode = False
    
14.         Set Rng(1) = .Range("J1").CurrentRegion
    
15.         Set Rng(1) = .Range(Rng(1)(2, 1), Rng(1)(Rng(1).Rows.Count, Rng(1).Columns.Count))
    
16.         For xi = DateValue(.[J2]) To DateValue(.[J2].End(xlDown))
    
17.             For Each Ea In Array("9:16:00", "13:31:00")
    
18.                 .AutoFilterMode = False
    
19.                 .Range("J1").AutoFilter 1, Format(xi, "MM/DD/yYYY")
    
20.                 .Range("J1").AutoFilter 2, Ea
    
21.                 Set Rng(2) = Rng(1).SpecialCells(xlCellTypeVisible)   '篩選不到資料 :有錯誤
    
22.                 If Err.Number = 0 Then
    
23.                     .AutoFilterMode = False
    
24.                     Rng(2).Resize(2).Insert
    
25.                     With Rng(2).Offset(-2).Resize(2)
    
26.                         .Interior.ColorIndex = 6
    
27.                         .Columns(1).Value = Rng(2).Cells(1)
    
28.                         .Cells(1, 2) = Rng(2).Cells(2) - #12:02:00 AM#
    
29.                         .Cells(2, 2) = Rng(2).Cells(2) - #12:01:00 AM#
    
30.                         .Columns("C:F") = Rng(2).Cells(3).Value
    
31.                     End With
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37. End Sub

複製代碼

GBKEE

回復 7# cdkee
附檔 試試看
自動篩選.rar (37.32 KB)

下載次數: 6

2012-4-30 10:10

1. Sub Ex()
   
2.     Dim xi As Date, Ea, Rng(1 To 3) As Range
   
3.     On Error Resume Next                                        '程式有錯誤繼續執行程式
   
4.     Application.ScreenUpdating = False                          '螢幕更新:取消
   
5.     With Sheet1
   
6.         .AutoFilterMode = False
   
7.         ' (False) 取消[自動篩選]下拉箭號 : 如先前有[自動篩選]過 會引響再次的另設準則後的篩選資料範圍
   
8.         Set Rng(1) = .Range("a1").CurrentRegion
   
9.         Set Rng(1) = .Range(Rng(1)(2, 1), Rng(1)(Rng(1).Rows.Count, Rng(1).Columns.Count))
   
10.         .[A1].AutoFilter Field:=2, Criteria1:="=9:16:00", Operator:=xlOr, Criteria2:="=13:31:00"
    
11.                                                                 '自動篩選 :第2欄 設下準則
    
12.         Set Rng(2) = Rng(1).SpecialCells(xlCellTypeVisible)     '依準則 [自動篩選] 到的資料區:如沒有資料    會有錯誤
    
13.         .AutoFilterMode = False                                 '取消[自動篩選]  顯示所有資料
    
14.         For Each Ea In Rng(2).Rows                              '處裡每一列(依準則 [自動篩選] 到的資料區)
    
15.             Ea.Resize(2).Insert                                 'Insert (插入) : [自動篩選]如不 顯示所有資料 會有錯誤
    
16.             With Ea.Offset(-2).Resize(2)
    
17.                 .Interior.ColorIndex = 6
    
18.                 .Columns(1).Value = Rng(2).Cells(1)
    
19.                 .Cells(1, 2) = Rng(2).Cells(2) - #12:02:00 AM#
    
20.                 .Cells(2, 2) = Rng(2).Cells(2) - #12:01:00 AM#
    
21.                 .Columns("C:F") = Rng(2).Cells(3).Value
    
22.              End With
    
23.         Next
    
24.     End With
    
25.     Application.ScreenUpdating = True                            ' 螢幕更新:恢復
    
26.     If Err.Number <> 0 Then MsgBox "找不到資料"
    
27. End Sub

複製代碼