返回列表 上一主題 發帖

[發問] 如何將每個時段內的指定數值抽出

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2013-8-26 18:17 | 顯示全部帖子
回復 3# donod
  1. Option Explicit
  2. Sub Ex()
  3.     Dim AR(), Rng As Range, i As Integer, A(1 To 6), T As Integer
  4.     ReDim AR(0)
  5.     With Sheets("Sheet1")
  6.         AR(0) = .[A1:F1]
  7.         Set Rng = .Range("b2")
  8.         T = 14 - Abs(Minute(Rng) Mod 15)        '距下一個15分鐘的分鐘數
  9.         i = 1
  10.         Do
  11.             If TimeValue(Rng.Offset(i)) > TimeValue(Rng) + TimeValue("00:" & T) Or Rng.Offset(i, -1) <> Rng.Offset(, -1) Or Rng.Offset(i) = "" Then          '
  12.                 A(1) = Rng.Resize(i).Cells(1).Offset(, -1)         'Date
  13.                 A(2) = Rng.Cells(1)                                'Time
  14.                 A(3) = Rng.Cells(1, 2)                             'Open
  15.                 A(4) = Application.Max(Rng.Resize(i).Offset(, 2))  'High
  16.                 A(5) = Application.Min(Rng.Resize(i).Offset(, 3))  'Low
  17.                 A(6) = Rng.Resize(i).Offset(, 4).Cells(i)          'Close
  18.                 ReDim Preserve AR(UBound(AR) + 1)
  19.                 AR(UBound(AR)) = A
  20.                 Set Rng = Rng.Offset(i)
  21.                 T = 14 - Abs(Minute(Rng) Mod 15)                    '距下一個15分鐘的分鐘數
  22.                 i = 1
  23.             Else
  24.                 i = i + 1
  25.             End If
  26.         Loop Until Rng.Offset(i) = ""
  27.         .[J1].CurrentRegion = ""
  28.         .[J1].Resize(UBound(AR) + 1, 6) = Application.Transpose(Application.Transpose(AR))
  29.     End With
  30. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2013-8-28 14:05 | 顯示全部帖子
回復 6# donod
  1. Option Explicit
  2. Sub Ex()
  3.     Dim AR(), Rng As Range, i As Integer, A(1 To 6), T As Integer
  4.     ReDim AR(0)
  5.     With Sheets("Sheet1")
  6.         .[B:B].Replace "000", "00", xlPart         '修改為時間格式 **********
  7.         AR(0) = .[A1:F1]
  8.         Set Rng = .Range("b2")
  9.         T = 14 - Abs(Minute(Rng) Mod 15)        '距下一個15分鐘的分鐘數
  10.         i = 1
  11.         Do
  12.            If Rng.Offset(i) > Rng + TimeValue("00:" & T) Or Rng.Offset(i, -1) <> Rng.Offset(, -1) Or Rng.Offset(i) = "" Then
  13.                 A(1) = Rng.Resize(i).Cells(1).Offset(, -1)         'Date
  14.                 A(2) = Rng.Cells(1).Text                               'Time
  15.                 A(3) = Rng.Cells(1, 2)                             'Open
  16.                 A(4) = Application.Max(Rng.Resize(i).Offset(, 2))  'High
  17.                 A(5) = Application.Min(Rng.Resize(i).Offset(, 3))  'Low
  18.                 A(6) = Rng.Resize(i).Offset(, 4).Cells(i)          'Close
  19.                 ReDim Preserve AR(UBound(AR) + 1)
  20.                 AR(UBound(AR)) = A
  21.                 Set Rng = Rng.Offset(i)
  22.                 T = 14 - Abs(Minute(Rng) Mod 15)                    '距下一個15分鐘的分鐘數
  23.                 i = 1
  24.             Else
  25.                 i = i + 1
  26.             End If
  27.         Loop Until Rng.Offset(i) = ""
  28.         .[J1].CurrentRegion = ""
  29.         .[J1].Resize(UBound(AR) + 1, 6) = Application.Transpose(Application.Transpose(AR))
  30.     End With
  31. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2013-9-1 11:56 | 顯示全部帖子
本帖最後由 GBKEE 於 2013-9-1 12:15 編輯

回復 8# donod
  1. Option Explicit
  2. Sub Ex()
  3.     Dim AR(), Rng As Range, i As Integer, A(1 To 6), T As Integer
  4.     Dim RT(1 To 2) As Single                       '****指定變數型態
  5.     ReDim AR(0)
  6.     With Sheets("Sheet1")
  7.         .[B:B].Replace "000", "00", xlPart         '修改為時間格式
  8.         AR(0) = .[A1:F1]
  9.         Set Rng = .Range("b2")
  10.         T = 14 - Abs(Minute(Rng) Mod 15)        '距下一個15分鐘的分鐘數
  11.         RT(1) = Rng + TimeValue("00:" & T)
  12.         i = 1
  13.         Do
  14.             RT(2) = Rng.Offset(i)
  15.             If RT(2) > RT(1) Or Rng.Offset(i, -1) <> Rng.Offset(, -1) Or Rng.Offset(i) = "" Then
  16.                 A(1) = Rng.Resize(i).Cells(1).Offset(, -1)         'Date
  17.                 A(2) = Rng.Cells(1).Text                               'Time
  18.                 A(3) = Rng.Cells(1, 2)                             'Open
  19.                 A(4) = Application.Max(Rng.Resize(i).Offset(, 2))  'High
  20.                 A(5) = Application.Min(Rng.Resize(i).Offset(, 3))  'Low
  21.                 A(6) = Rng.Resize(i).Offset(, 4).Cells(i)         'Close
  22.                 ReDim Preserve AR(UBound(AR) + 1)
  23.                 AR(UBound(AR)) = A
  24.                 Set Rng = Rng.Offset(i)
  25.                 T = 14 - Abs(Minute(Rng) Mod 15)                    '距下一個15分鐘的分鐘數
  26.                 RT(1) = Rng + TimeValue("00:" & T)
  27.                 i = 1
  28.             Else
  29.                 i = i + 1
  30.             End If
  31.         Loop Until Rng.Offset(i) = ""
  32.         .[J1].CurrentRegion = ""
  33.         .[J1].Resize(UBound(AR) + 1, 6) = Application.Transpose(Application.Transpose(AR))
  34.     End With
  35. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2013-9-2 18:22 | 顯示全部帖子
回復 11# donod
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 3) As Range, i  As Integer, Ar(), S
  4.     Set Rng(1) = Sheets("Sheet1").Range("b:b")
  5.     Ar = Array(#9:14:00 AM#, #12:59:00 PM#, #4:59:00 PM#, #4:15:00 PM#, #12:00:00 PM#, #11:00:00 PM#)
  6.     For i = 0 To UBound(Ar)
  7.         Set Rng(2) = Rng(1).Find(Ar(i), LookIn:=xlFormulas)
  8.         If Not Rng(2) Is Nothing Then
  9.             S = Rng(2).Address
  10.             Do
  11.                 If i <= Int(UBound(Ar) / 2) Then
  12.                     Rng(2).Offset(1, 1) = Rng(2).Offset(, 1)
  13.                 Else
  14.                     Rng(2).Offset(-1, 4) = Rng(2).Offset(, 4)
  15.                 End If
  16.                 If Not Rng(3) Is Nothing Then
  17.                     Set Rng(3) = Union(Rng(3), Rng(1).Parent.Range(Rng(1).Parent.Cells(Rng(2).Row, "a"), Rng(1).Parent.Cells(Rng(2).Row, "g")))
  18.                 Else
  19.                     Set Rng(3) = Rng(1).Parent.Range(Rng(1).Parent.Cells(Rng(2).Row, "a"), Rng(1).Parent.Cells(Rng(2).Row, "g"))
  20.                 End If
  21.                 Set Rng(2) = Rng(1).FindNext(Rng(2))
  22.             Loop Until S = Rng(2).Address
  23.         End If
  24.     Next
  25.      If Not Rng(3) Is Nothing Then Rng(3).Delete
  26. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2013-9-5 14:00 | 顯示全部帖子
回復 14# donod
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Variant, E As Range
  4.     For Each E In Range("b2", [b2].End(xlDown))
  5.         D = Split(E.Offset(, -1), "/")
  6.         E.Value = E + #12:01:00 AM#
  7.         E.Offset(, 6) = D(0) & D(1) & Replace(E.Text, ":", "")
  8.     Next
  9. End Sub
複製代碼
還是
  1. Sub Ex1()
  2.     Dim D As Variant, E As Range, b As Date
  3.     For Each E In Range("b2", [b2].End(xlDown))
  4.         b = E + #12:01:00 AM#
  5.         D = Split(E.Offset(, -1), "/")
  6.         E.Offset(, 6) = D(0) & D(1) & Application.Text(b, "hhmm")
  7.     Next
  8. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2013-9-5 20:18 | 顯示全部帖子
回復 18# donod
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Variant, E As Range, b As Date
  4.     With Workbooks("A.xls").Sheets("Sheet1")
  5.         For Each E In .Range("b2", .[b2].End(xlDown))
  6.             D = Split(E.Offset(, -1), "/")
  7.             b = E + #12:01:00 AM#
  8.             E.Value = E + #12:01:00 AM#
  9.             E.Offset(, 6) = D(0) & D(1) & Application.Text(b, "hhmm")
  10.         Next
  11.     End With
  12. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2013-9-12 14:51 | 顯示全部帖子
回復 21# handsometrowa
Dim AR(),  這裡宣告一組陣列變數我了解                -> 瞭解它是動態陣列,空的陣列??
ReDim AR(0)  為什麼這裡馬上就要重新定義陣列變數呢?   ->新增一元素 (作為表頭用的)  
重新把元素賦予給 AR(0)  這是什麼意思                  -> 請按F8 逐行執行程式,過了行 AR(0) = .[A1:F1] 到[檢視]-[區域變數視窗] 看AR(0)的內容
例如  .[B5:F9] => 二維陣列( 1 To  9 - 4 , 1 To  5 [B欄 - F欄的 欄數] ) =>二維陣列( 列數 , 欗數 )
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 【蒙蔽的自由】人常在什麼都可以自由自在的時候，卻被這種隨心所欲的自由蒙蔽，虛擲時光而毫無覺知。
返回列表 上一主題