Board logo

標題: [發問] 請問日價格怎麼轉變成週價格呢? [打印本頁]
作者: jovi0801    時間: 2012-7-8 23:26     標題: 請問日價格怎麼轉變成週價格呢?

不知道這能用公式解決嗎?還是要寫程式碼才能完成呢?
作者: GBKEE    時間: 2012-7-9 17:02

回復 1# jovi0801
試試看
  1. Sub Ex() 'DatePart("WW", .Rows(xi).Cells(1))  傳回第幾週
  2.     Dim Rng As Range, xi As Integer
  3.     With Sheets("日價格").Range("A1").CurrentRegion.Rows
  4.         Set Rng = .Rows(1)
  5.         xi = 2
  6.         Do
  7.             If DatePart("WW", .Rows(xi).Cells(1)) <> DatePart("WW", .Rows(xi + 1).Cells(1)) Then Set Rng = Union(Rng, .Rows(xi))
  8.             xi = xi + 1
  9.            If xi = .Rows.Count Then Set Rng = Union(Rng, .Rows(xi))
  10.         Loop While xi < .Rows.Count
  11.     End With
  12.     With Sheets("周價格")
  13.         .UsedRange.Clear
  14.         Rng.Copy .[a1]
  15.     End With
  16. End Sub
複製代碼
作者: jovi0801    時間: 2012-7-9 19:17

回復 2# GBKEE
感謝版主的解答,透過版主的程式碼,只要把"WW"變成"m"就會變成月價格囉!
作者: jovi0801    時間: 2012-7-9 20:56

回復 2# GBKEE


    不好意思,我仔細一看,這程式碼,是把每週五的開低收高秀出來,那我想把開盤價設在週一,最高最低是這在週所出現的數值,收盤當然週五最後的價格,我有看到對岸寫的程式碼,但我不知道要從而改起,請版主看看
Sub bwwweek()
‘建立新的工作表, 存放周数据
ActiveWorkbook.Sheets.Add after:=Worksheets(1)
Worksheets(1).Activate

‘把第一行数据存到变量，hand为行号，h为最高，l为最低，c为收盘，d为日期，vol为成交股数，amt为成交金额

Dim hand As Integer, h As Double, l As Double, _
c As Double, d As Date, o As Double, _
vol As Long, amt As Long
hand = 1
d = Worksheets(1).Cells(hand, 1).Value

‘交易第一天离开星期五有几天,n5计数器，fri储存星期五的日期
Dim n5 As Integer, md5 As Date
For n5 = 0 To 4
fri = d + n5
If Weekday(fri) – 1 = 5 Then
Exit For
End If
Next n5

‘第一周的行数,row1为本周第一交易日行数，row5为本周最后交易日行数, frim暂储存一周内交易日的数据, 用于和这周fri日期比较,大于fri即计算本周最后交易日行数
Dim row1 As Integer, row5 As Integer, frim As Date
row1 = 1

Dim n As Integer
For n = 1 To 6
If frim > fri Then
row5 = n – 1
Exit For
End If
frim = Worksheets(1).Cells((hand + n), 1).Value
Next n

‘把总共股票日K线原始数据的行数储存在rng变量
Dim rng As Integer
rng = Range(“A65536〃).End(xlUp).Row

Dim whand As Integer, wdate As Date
whand = 1
‘==========================================================
While row1 <= rng
‘——————————————————
If frim >= fri Or frim = 0 Then

‘把一周开盘,收盘,量等存入变量, 用于下面写入周的新工作表
wopen = Worksheets(1).Cells(row1, 2).Value
whigh = Application.WorksheetFunction.Max(Range(Cells(row1, 3), Cells(row5, 3)))
wlow = Application.WorksheetFunction.Min(Range(Cells(row1, 4), Cells(row5, 4)))
wclose = Worksheets(1).Cells(row5, 5).Value
wdate = Worksheets(1).Cells(row1, 1).Value

hand = row5 + 1

Worksheets(2).Cells(whand, 1).Value = wdate
Worksheets(2).Cells(whand, 2).Value = wopen
Worksheets(2).Cells(whand, 3).Value = whigh
Worksheets(2).Cells(whand, 4).Value = wlow
Worksheets(2).Cells(whand, 5).Value = wclose
whand = whand + 1

End If
‘————————————————————-
If hand <= rng And frim <> 0 Then

frim = Worksheets(1).Cells(hand, 1).Value
‘-  -  -  -  -  -  -
For n5 = 0 To 4
fri = frim + n5

If Weekday(fri) – 1 = 5 Then
Exit For
End If
Next n5
‘-  -  -  -  -  -  -

row1 = row5 + 1
‘///////////////////////////////////////////////////
For n = 1 To 6
If frim > fri Or frim = 0 Then
row5 = row5 + n – 1
Exit For
End If
frim = Worksheets(1).Cells((hand + n), 1).Value
Next n
‘//////////////////////////////////////////////////
Else
row1 = row5 + 1
End If
‘———————————————————–
Wend
‘===================================================
End Sub
作者: GBKEE    時間: 2012-7-10 15:58

本帖最後由 GBKEE 於 2012-7-10 16:02 編輯

回復 4# jovi0801
  1. Sub Ex() 'DatePart("WW", .Rows(xi).Cells(1))  傳回第幾週
  2.     Dim AR, xi As Integer, xAr As Integer, Rng As Range
  3.     With Sheets("日價格")
  4.         AR = Application.Transpose(.Range("A1").CurrentRegion.Rows(1).Value)         '取得欄位
  5.         xAr = 2
  6.         xi = 2
  7.         ReDim Preserve AR(1 To 5, 1 To xAr)                             '新增一維空白陣列
  8.         Set Rng = .Cells(xi, "A")                                       '一週營業的第一天日期位置
  9.         Do While .Cells(xi, "A") <> ""
  10.             If DatePart("WW", .Cells(xi, "A")) <> DatePart("WW", .Cells(xi + 1, "A")) Then
  11.                 Set Rng = Range(Rng, .Cells(xi, "E"))                   '一週營業的第一天日期位置  到  最後第一天收盤價位置
  12.                 AR(1, xAr) = Rng.Cells(1)                               '日期  Rng.Cells(1) 日期: 週一  或 .Cells(xi, "A") 日期: 週五(最後一天)
  13.                 AR(2, xAr) = Rng.Cells(1, 2)                            '開盤價
  14.                 AR(3, xAr) = Application.Max(Rng.Columns(3))            '最高價
  15.                 AR(4, xAr) = Application.Min(Rng.Columns(4))             '最低價
  16.                 AR(5, xAr) = .Cells(xi, "E")                            '收盤價
  17.                 If .Cells(xi + 1, "A") <> "" Then
  18.                     Set Rng = .Cells(xi + 1, "a")
  19.                     xAr = xAr + 1
  20.                     ReDim Preserve AR(1 To 5, 1 To xAr)
  21.                 End If
  22.             End If
  23.             xi = xi + 1
  24.         Loop
  25.     End With
  26.     With Sheets("周價格")
  27.         .UsedRange.Clear
  28.         .[A1].Resize(xAr, 5) = Application.Transpose(AR)
  29.     End With
  30. End Sub
複製代碼
作者: Hsieh    時間: 2012-7-10 18:38

回復 4# jovi0801
如果這是交易紀錄，不應該判斷周一與周五為區間
因為有可能遇到假日休市，以周別判定不知是否比較正確?
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. Set d1 = CreateObject("Scripting.Dictionary")
  4. With Sheet1
  5. d1(1) = Array(.[A1].Value, .[B1].Value, .[C1].Value, .[d1].Value, .[E1].Value)
  6. For Each a In .Range(.[A2], .[A2].End(xlDown))
  7. w = Year(a) & ":" & Application.WorksheetFunction.WeekNum(a)
  8. If IsEmpty(d(w & "開")) Then d(w & "開") = a.Offset(, 1).Value
  9. If a.Offset(, 2) > d(w & "高") Then d(w & "高") = a.Offset(, 2).Value
  10. If IsEmpty(d(w & "低")) Then
  11. d(w & "低") = a.Offset(, 3).Value
  12. ElseIf d(w & "低") > a.Offset(, 3) Then
  13. d(w & "低") = a.Offset(, 3).Value
  14. End If
  15. d(w & "收") = a.Offset(, 4).Value
  16. d1(w) = Array(a.Value, d(w & "開"), d(w & "高"), d(w & "低"), d(w & "收"))
  17. Next
  18. End With
  19. With Sheet2
  20. .Cells = ""
  21. .[A1].Resize(d1.Count, 5) = Application.Transpose(Application.Transpose(d1.items))
  22. End With
  23. End Sub
複製代碼
作者: jovi0801    時間: 2012-7-10 23:23

回復 5# GBKEE
再次感謝GBKEE版主的協助,解決我的問題
作者: jovi0801    時間: 2012-7-10 23:51

回復 6# Hsieh
謝謝Hsieh超級版主的提醒,但套用您的程式碼,會出現物件不支援此屬性或方法的訊息,而GBKEE版主所寫的程式碼,好像能達到您所說的效果,如附件[attach]11636[/attach]
作者: c_c_lai    時間: 2012-7-12 08:30

回復 5# GBKEE
回復 8# jovi0801
我加上了一欄 "期間" (scope) 如此可以清楚地看出它們的歸屬。
純參考，希望 GBKEE 大大莫介意。
  1. Sub Ex()                           ' DatePart("WW", .Rows(xi).Cells(1))  傳回第幾週
  2.     Dim AR, xi As Integer, xAr As Integer, Rng As Range, scope As String
  3.    
  4.     With Sheets("日價格")
  5.         AR = Application.Transpose(.Range("A1").CurrentRegion.Rows(1).Value)     ' 取得欄位
  6.         xAr = 2
  7.         xi = 2
  8.         ReDim Preserve AR(1 To 6, 1 To xAr)                      ' 新增一維空白陣列
  9.         
  10.         Set Rng = .Cells(xi, "A")                                ' 一週營業的第一天日期位置
  11.         scope = .Cells(xi, "A")
  12.         
  13.         Do While .Cells(xi, "A") <> ""
  14.             If DatePart("WW", .Cells(xi, "A")) <> DatePart("WW", .Cells(xi + 1, "A")) Then
  15.                 Set Rng = Range(Rng, .Cells(xi, "E"))            ' 一週營業的第一天日期位置  到  最後第一天收盤價位置
  16.                 AR(1, xAr) = Rng.Cells(1)           ' 日期  Rng.Cells(1) 日期: 週一  或 .Cells(xi, "A") 日期: 週五(最後一天)
  17.                 AR(2, xAr) = Rng.Cells(1, 2)                     ' 開盤價
  18.                 AR(3, xAr) = Application.Max(Rng.Columns(3))     ' 最高價
  19.                 AR(4, xAr) = Application.Min(Rng.Columns(4))     ' 最低價
  20.                 AR(5, xAr) = .Cells(xi, "E")                     ' 收盤價
  21.                 AR(6, xAr) = scope & "-" & .Cells(xi, "A")
  22.                
  23.                 If .Cells(xi + 1, "A") <> "" Then
  24.                     Set Rng = .Cells(xi + 1, "A")
  25.                     xAr = xAr + 1
  26.                     scope = .Cells(xi + 1, "A")
  27.                     ReDim Preserve AR(1 To 6, 1 To xAr)
  28.                 End If
  29.             End If
  30.             xi = xi + 1
  31.         Loop
  32.     End With
  33.    
  34.     With Sheets("周價格")
  35.         .UsedRange.Clear
  36.         .[A1].Resize(xAr, 6) = Application.Transpose(AR)
  37.     End With
  38. End Sub
複製代碼
[attach]11649[/attach]
作者: GBKEE    時間: 2012-7-12 14:11

回復 9# c_c_lai
加上期間這不錯啊 ,但可不需新增變數來顯示.   
AR(6, xAr) = scope & "-" & .Cells(xi, "A")   ->      AR(6, xAr) = Rng.Cells(1) & "-" & .Cells(xi, "A")
作者: c_c_lai    時間: 2012-7-12 14:28

回復 10# GBKEE
謝謝指導！
目前我對於 Set Rng 的應用尚未十分孰悉，可能是以往沒接觸過Excel
的緣故。 我會再加強這方面的應用， 謝謝您！
作者: jovi0801    時間: 2012-7-13 11:30

回復 11# c_c_lai
回復 10# GBKEE
沒有想到有新的版本出現,雖然我無法看到長什麼樣子也謝謝兩位的加強
作者: diabo    時間: 2012-7-13 22:02

工具→設定引用項目→Microsoft ActiveX Data Objects 2.8 Library

用 SQL來解決日轉週、轉月、轉季......轉檔問題
  1. Sub 日線轉週線()

  3.    '建立日期與年週對照字典檔
  4.     Dim d
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     Dim c As Range
  7.     For Each c In Sheets("日價格").Range("A2:A" & Sheets("日價格").[A2].End(xlDown).Row)
  8.    
  9.        '將日期轉為年週，例如201215表示2012年第15週
  10.         yyyyww = Year(c.Value) & Format(DatePart("ww", c.Value), "00")
  11.         
  12.        '檢查年週是否在字典檔中，若不存在則加入
  13.         If Not d.Exists(yyyyww) Then
  14.             d.Add yyyyww, c.Value
  15.         End If
  16.     Next

  18.    '刪除【周價格2】工作表暨存的資料
  19.     With Sheets("周價格2")
  20.         .[A1:E1].Value = Sheets("日價格").[A1:E1].Value
  21.         .Activate
  22.         .Rows("2:" & .[A2].End(xlDown).Row).ClearContents
  23.     End With
  24.    
  25.    '建立ADODB Connection物件變數
  26.     Dim cn As ADODB.Connection
  27.     Set cn = New ADODB.Connection
  28.    
  29.     With cn
  30.         .Provider = "MSDASQL"
  31.         .ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
  32.          "DBQ=" & ThisWorkbook.FullName & ";"
  33.         .Open
  34.     End With
  35.    
  36.    'SQL字串
  37.     mySQL = "Select 年週,FIRST(開盤價), MAX(最高價), MIN(最低價), LAST(收盤價) From ((SELECT (YEAR(日期)& FORMAT(DATEPART('ww',日期),'00')) AS 年週, 開盤價, 最高價, 最低價, 收盤價 FROM [日價格$A:E] WHERE 日期 IS NOT NULL) tmpTable) GROUP BY 年週"
  38.    
  39.     Set rs = cn.Execute(mySQL)

  41.     With Sheets("周價格2")
  42.         .Activate
  43.         .Range("A2").CopyFromRecordset rs
  44.     End With
  45.    
  46.    '將年週轉為該週第一個交易日期
  47.     For Each c In Sheets("周價格2").Range("A2:A" & Sheets("周價格2").[A2].End(xlDown).Row)
  48.         c.Value = d.Item(c.Value)
  49.     Next
  50.    
  51.    '關閉連線清除記憶體
  52.     cn.Close
  53.     Set cn = Nothing
  54.    
  55.     MsgBox "轉檔完成!"

  57. End Sub
複製代碼




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