Board logo

標題: [發問] 在每個指定的時間插入相關數據(已解決) [打印本頁]
作者: cdkee    時間: 2012-4-29 04:47     標題: 在每個指定的時間插入相關數據(已解決)

本帖最後由 cdkee 於 2012-5-1 22:19 編輯

請教大大，如何在SHEET1中左手邊的數據，要在每天每個9:16:000和13:31:000，在其上插入兩行數據，將結果顯示在右邊。
不知怎麼說，效果就如SHEET1中右手邊顯示的數據，插入兩行的數據(綠色)是與左手邊的相關數據(綠色)相同。
謝謝!
[attach]10728[/attach]
作者: cdkee    時間: 2012-4-29 15:38

是否我的做法不行，煩請教各位大大指教，感謝!
作者: GBKEE    時間: 2012-4-29 17:29

回復 2# cdkee
  9:16:000和13:31:000   這格式多一個0
作者: register313    時間: 2012-4-29 18:37

回復 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    時間: 2012-4-29 20:44

回復 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    時間: 2012-4-29 22:06

回復 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

  21. Next
  22. .[A1].Resize(s, 7) = Application.Transpose(Application.Transpose(Ar))
  23. End With
  24. .Save '存檔
  25. End With
  26. End Sub
複製代碼
作者: cdkee    時間: 2012-4-30 01:09

本帖最後由 cdkee 於 2012-4-30 03:25 編輯

先謝謝三位大大用心指導!
試了三位大大的公式，還是跑不出來，是我改錯了什麼，還請大大再指教，謝謝!
[attach]10740[/attach]
[attach]10741[/attach]
[attach]10742[/attach]
作者: register313    時間: 2012-4-30 07:56

回復 7# cdkee
一般模組要加在Module內
活頁簿模組才加在ThisWorkbook內
工作表模組則加在Sheet內
[attach]10743[/attach]
作者: Hsieh    時間: 2012-4-30 08:23

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

回復 7# cdkee
附檔 試試看
[attach]10748[/attach]
  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
複製代碼
作者: cdkee    時間: 2012-4-30 15:51

再謝謝Hsieh 大大GBKEE 大大細心指導!
作者: cdkee    時間: 2012-4-30 16:01

本帖最後由 cdkee 於 2012-4-30 16:06 編輯

回復 8# register313


    感謝register313大大，今回可跑了!
但當數據有2個月或以上，每個月第1日的日期出來有點問題...
[attach]10757[/attach]
作者: register313    時間: 2012-4-30 16:54

回復 12# cdkee

有2行加入.text

[attach]10758[/attach]
作者: cdkee    時間: 2012-4-30 21:44

回復 13# register313


    謝謝大大的回覆!
但新插入的日子FORMAT與原本的不同，應如何改動，謝謝!
作者: register313    時間: 2012-4-30 23:29

回復 14# cdkee

你12樓給我的檔案
1.A欄的日期格式有2種,所以J欄的日期格式也有2種
  A欄的日期格式若改為1種,J欄的日期格式就只有1種
  總之J欄的日期格式與A欄的日期格式相同
2.你改為刪除1列,有些程式碼沒改到,複製的數據是錯的

下列檔案再試看看
[attach]10761[/attach]
作者: cdkee    時間: 2012-5-1 00:55

回復 15# register313


    謝謝大大的再三指導!
終於跑順了，根據大大教的，試了多次，也加入可插入2行數據的版本，謝謝各位大大!
[attach]10763[/attach]
作者: Andy2483    時間: 2023-3-10 10:59

回復 16# cdkee


    謝謝前輩發表此主題與範例,謝謝各位前輩
後學練習以2個陣列方式處裡,請各位前輩指導

執行前:
[attach]35913[/attach]

執行結果:
[attach]35914[/attach]

Option Explicit
Sub TEST()
Dim Brr, Crr, Z, i&, N&, j&, T$
Brr = Range([G1], Cells(Rows.Count, "A").End(3))
ReDim Crr(1 To UBound(Brr) * 2, 1 To UBound(Brr, 2))
For i = 1 To UBound(Brr)
   T = Brr(i, 2)
   If InStr("/9:16:000/13:31:000/", "/" & T & "/") Then
      N = N + 1
      Crr(N, 1) = Brr(i, 1): Z = Split(T, ":")
      Crr(N, 2) = Join(Array(Z(0), Z(1) - 1, Z(2)), ":")
      For j = 3 To 6
         Crr(N, j) = Brr(i, 3)
      Next
   End If
   N = N + 1
   For j = 1 To UBound(Brr, 2)
      Crr(N, j) = Brr(i, j)
   Next
Next
[J1].Resize(N, UBound(Crr, 2)) = Crr
Erase Brr, Crr
End Sub
作者: Andy2483    時間: 2023-3-10 12:07

回復 17# Andy2483


    後學延伸練習以字典+二維陣列+一維陣列 處裡,請各位前輩指導

Option Explicit
Sub TEST_2()
Dim Brr, Z, Y, B, i&, N&, j&, T$, A(6)
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([G1], Cells(Rows.Count, "A").End(3))
For i = 1 To UBound(Brr)
   T = Brr(i, 2)
   If InStr("/9:16:000/13:31:000/", "/" & T & "/") Then
      N = N + 1: B = A
      B(0) = Brr(i, 1): Z = Split(T, ":")
      B(1) = Join(Array(Z(0), Z(1) - 1, Z(2)), ":")
      For j = 2 To 5
         B(j) = Brr(i, 3)
      Next
      Y(N) = B
   End If
   N = N + 1: B = A
   For j = 0 To UBound(B)
      B(j) = Brr(i, j + 1)
   Next
   Y(N) = B
Next
[J1].Resize(N, UBound(A) + 1) = Application.Transpose(Application.Transpose(Y.Items))
Erase Brr, B, A: Set Y = Nothing
End Sub
作者: Andy2483    時間: 2023-3-13 11:58

本帖最後由 Andy2483 於 2023-3-13 12:01 編輯

回復 18# Andy2483


    謝謝論壇,謝謝各位前輩
後學複習心得如下,請各位前輩指教

Option Explicit
Sub TEST_1()
Dim Brr, Crr, Z, i&, N&, j&, T$
'↑宣告變數:(Brr,Crr,Z)是通用型變數,(i,N,j)是長整數變數,T是字串變數
Brr = Range([G1], Cells(Rows.Count, "A").End(3))
'↑令Brr這通用型變數是二維陣列,以[G1]到A欄最後有內容儲存格值帶入
ReDim Crr(1 To UBound(Brr) * 2, 1 To UBound(Brr, 2))
'↑宣告Crr是二維陣列,範圍大小,縱向從1到Brr陣列縱向最大索引列號數的2倍,
'橫向從1到 Brr陣列橫向最大索引欄號數
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到 Brr陣列縱向為大索引列號
   T = Brr(i, 2)
   '↑令T這字串變數是 i迴圈列第2欄Brr陣列值
   If InStr("/9:16:000/13:31:000/", "/" & T & "/") Then
   '↑如果T變數的前後各連接"/"符號後的新字串,在指定的字串裡被包含了??
   '指定的字串:"/9:16:000/13:31:000/"
      N = N + 1
      '↑令N這長整數變數累加1
      Crr(N, 1) = Brr(i, 1): Z = Split(T, ":")
      '↑令N變數列第1欄Crr陣列值是 i迴圈列第1欄Brr陣列值:
      '令Z變數是一維陣列,令T變數以":"分割後帶入
      Crr(N, 2) = Join(Array(Z(0), Z(1) - 1, Z(2)), ":")
      '↑令N變數列第2欄Crr陣列值是
      '(第0索引Z陣列值,第1索引Z陣列值-1,第2索引Z陣列值)
      '這三個字串以":"串接成新字串
      For j = 3 To 6
      '↑設順迴圈!j從3到6
         Crr(N, j) = Brr(i, 3)
         '↑令N變數列第j迴圈欄Crr陣列值是 i變數列第3欄Brr陣列值
      Next
   End If
   N = N + 1
   '↑令N變數累加1
   For j = 1 To UBound(Brr, 2)
   '↑設順迴圈!j從1到Brr陣列橫向最大索引欄號數
      Crr(N, j) = Brr(i, j)
      '↑令N變數列第j迴圈欄Crr陣列值是 i變數列第j迴圈欄Brr陣列值
   Next
Next
[J1].Resize(N, UBound(Crr, 2)) = Crr
'↑令[J1]擴展向下N變數列,擴展向右Crr橫向最大所欄號數,
'這範圍儲存格值以 Crr陣列值帶入
Erase Brr, Crr, Z
'↑令釋放變數
End Sub

==========================================================

Option Explicit
Sub TEST_2()
Dim Brr, Z, Y, B, i&, N&, j&, T$, A(6)
'↑宣告變數:(Brr,Z,Y,B)是通用型變數,(i,N,j)是長整數變數,T是字串變數,
'A是一維陣列(0~6)空陣列
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Brr = Range([G1], Cells(Rows.Count, "A").End(3))
'↑令Brr這通用型變數是二維陣列,以[G1]到A欄最後有內容儲存格值帶入
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到 Brr陣列縱向最大索引列號
   T = Brr(i, 2)
   '↑令T這字串變數是 i迴圈列第2欄Brr陣列值
   If InStr("/9:16:000/13:31:000/", "/" & T & "/") Then
   '↑如果T變數的前後各連接"/"符號後的新字串,在指定的字串裡被包含了??
   '指定的字串:"/9:16:000/13:31:000/"
      N = N + 1: B = A
      '↑令N這長整數變數累加1:令B這通用型變數是A這空陣列
      B(0) = Brr(i, 1): Z = Split(T, ":")
      '↑令0索引號B陣列值是 i迴圈列第1欄Brr陣列值:
      '令Z變數是一維陣列,令T變數以":"分割後帶入
      B(1) = Join(Array(Z(0), Z(1) - 1, Z(2)), ":")
      '↑令0索引號B陣列值是
      '(第0索引Z陣列值,第1索引Z陣列值-1,第2索引Z陣列值)
      '這三個字串以":"串接成新字串
      For j = 2 To 5
      '↑設順迴圈!j從2到 5
         B(j) = Brr(i, 3)
         '↑令j索引號B陣列值是 i迴圈列第3欄Brr陣列值
      Next
      Y(N) = B
      '↑令N變數為key,item是B變數納入Y字典裡
   End If
   N = N + 1: B = A
   '↑令N變數累加1 :令B變數是A變數
   For j = 0 To UBound(B)
   '↑設順迴圈!j從0到 B陣列最大索引號
      B(j) = Brr(i, j + 1)
      '↑令j迴圈B陣列值是 i迴圈列第j迴圈+1欄Brr陣列值
   Next
   Y(N) = B
   '↑令N變數為key,item是B變數納入Y字典裡
Next
[J1].Resize(N, UBound(A) + 1) = Application.Transpose(Application.Transpose(Y.Items))
'↑令[J1]擴展向下N變數列,擴展向右A陣列最大索引號+1欄,
'這範圍儲存格值以 Y字典的item轉置兩次帶入
Erase Brr, B, A, Z: Set Y = Nothing
'↑令釋放變數
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)