[發問] 在每個指定的時間插入相關數據(已解決)

cdkee

請教大大，如何在SHEET1中左手邊的數據，要在每天每個9:16:000和13:31:000，在其上插入兩行數據，將結果顯示在右邊。
不知怎麼說，效果就如SHEET1中右手邊顯示的數據，插入兩行的數據(綠色)是與左手邊的相關數據(綠色)相同。
謝謝!
TEST.rar (85.26 KB)

下載次數: 25

2012-4-29 04:45

cdkee

是否我的做法不行，煩請教各位大大指教，感謝!

GBKEE

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

register313

回復 1# cdkee
參考,資料量大時速度慢

1. Sub aa()
   
2. [A:G].Copy [J1]
   
3. For K = [K1].End(xlDown).Row To 1 Step -1
   
4.   T = Cells(K, "K")
   
5.   If T = "9:16:000" Or T = "13:31:000" Then
   
6.     Cells(K, "J").Resize(1, 7).Insert Shift:=xlDown
   
7.     Cells(K, "J").Resize(1, 7).Insert Shift:=xlDown
   
8.     Cells(K, "J").Resize(2, 1) = Cells(K + 2, "J")
   
9.     Cells(K, "L").Resize(2, 5) = Cells(K + 2, "L")
   
10.     Select Case T
    
11.       Case "9:16:000"
    
12.         Cells(K, "K") = "9:14:000"
    
13.         Cells(K + 1, "K") = "9:15:000"
    
14.       Case "13:31:000"
    
15.         Cells(K, "K") = "13:29:000"
    
16.         Cells(K + 1, "K") = "13:30:000"
    
17.     End Select
    
18.   End If
    
19. Next K
    
20. End Sub

複製代碼

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

複製代碼

Hsieh

回復 1# cdkee
資料覆蓋

1. Sub Ex()
   
2. Dim A As Range, Rng As Range, Ar(), t As Date
   
3. fs = ThisWorkbook.Path & "\TEST.xlsx" '要處理的檔案
   
4. With Workbooks.Open(fs)
   
5. With .Sheets(1)
   
6. For Each A In .Range(.[B1], .[B1].End(xlDown))
   
7. If Format(A, "hh:mm:ss") = "09:16:00" Or Format(A, "hh:mm:ss") = "13:31:00" Then
   
8. k = A.Offset(, 1): t = CDate(Format(A, "hh:mm:ss")) - TimeValue("00:02:00")
   
9.    For i = 1 To 2
   
10.        ReDim Preserve Ar(s)
    
11.        X = Format(t, "h:mm:ss0")
    
12.        Ar(s) = Array(A.Offset(, -1), X, k, k, k, k, "")
    
13.        s = s + 1
    
14.     t = t + TimeValue("00:01:00")
    
15.   Next
    
16. End If
    
17.    ReDim Preserve Ar(s)
    
18.    Ar(s) = Array(A.Offset(, -1).Value, A.Value, A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value, A.Offset(, 4).Value, A.Offset(, 5).Value)
    
19.    s = s + 1
    
20. 
    
21. Next
    
22. .[A1].Resize(s, 7) = Application.Transpose(Application.Transpose(Ar))
    
23. End With
    
24. .Save '存檔
    
25. End With
    
26. End Sub

複製代碼

cdkee

先謝謝三位大大用心指導!
試了三位大大的公式，還是跑不出來，是我改錯了什麼，還請大大再指教，謝謝!
register313.rar (85.24 KB)

下載次數: 3

2012-4-30 01:16

GBKEE.rar (86.28 KB)

下載次數: 7

2012-4-30 01:16

Hsieh.rar (85.54 KB)

下載次數: 6

2012-4-30 01:16

register313

回復 7# cdkee
一般模組要加在Module內
活頁簿模組才加在ThisWorkbook內
工作表模組則加在Sheet內
register313.rar (53.89 KB)

下載次數: 5

2012-4-30 07:56

Hsieh

回復 7# cdkee
一樓的壓縮檔有2個EXCEL檔案，我在想你是要以TEST.xlsm中的巨集來開啟TEST.xlsx檔案
然後修改TEST.xlsx的內容，所以加上了開啟檔案的動作
如果你的程式碼放在TEST.xlsx的任何模組內，都一樣造成重複開啟檔案的錯誤

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

複製代碼