返回列表 上一主題 發帖

[發問] 篩選資料並且放到新的Sheet裡

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2011-3-23 16:50 | 顯示全部帖子
本帖最後由 Hsieh 於 2011-3-23 16:56 編輯

回復 3# candy516
  1. Sub ex()
  2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set sht = Sheets.Add(after:=Sheets(1))
  5. Application.ScreenUpdating = False
  6. With Sheet1
  7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  8.       mystr = A & "," & Left(A.Offset(, 1), 4)
  9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
  10.    Next
  11. End With
  12. k = 1: r = 1
  13. For Each ky In d.keys
  14. y = Split(ky, ",")(1)
  15. With Sheets(y)
  16. Set C = .Columns("A").Find(d(ky))
  17. If Not C Is Nothing Then
  18.    Set B = .Rows(1).Find(Split(ky, ",")(0))
  19.    Set B1 = .[A1:A2]
  20.    Set B2 = B.Resize(2, 1)
  21.    Set Rng = C.Resize(15, 1)
  22.    Set Rng1 = .Cells(C.Row, B.Column).Resize(15, 1)
  23.    With sht
  24.       B1.Copy .Cells(r, k)
  25.       B2.Copy .Cells(r, k + 1)
  26.       Rng.Copy .Cells(r + 2, k)
  27.       Rng1.Copy .Cells(r + 2, k + 1)
  28.    End With
  29.    k = IIf(k = 255, 1, k + 2)
  30.    r = IIf(k = 1, r + 18, r)
  31.    Else
  32.    MsgBox "無此除權資料"
  33. End If
  34. End With
  35. Next
  36. Application.ScreenUpdating = True
  37. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2011-3-23 17:39 | 顯示全部帖子
回復 5# candy516
日期順序看錯，要往上15天才對
順便將無資料條件改一下
  1. Sub ex()
  2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set sht = Sheets.Add(after:=Sheets(1))
  5. Application.ScreenUpdating = False
  6. With Sheet1
  7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  8.       mystr = A & "," & Left(A.Offset(, 1), 4)
  9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
  10.    Next
  11. End With
  12. k = 1: r = 1
  13. For Each ky In d.keys
  14. y = Split(ky, ",")(1)
  15. With Sheets(y)
  16. Set C = .Columns("A").Find(d(ky))
  17. Set B = .Rows(1).Find(Split(ky, ",")(0))
  18. If Not C Is Nothing And Not B Is Nothing Then
  19. x = Application.Max(3, C.Row - 14)
  20.    Set B1 = .[A1:A2]
  21.    Set B2 = B.Resize(2, 1)
  22.    Set Rng = .Cells(x, 1).Resize(15, 1)
  23.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
  24.    With sht
  25.       B1.Copy .Cells(r, k)
  26.       B2.Copy .Cells(r, k + 1)
  27.       Rng.Copy .Cells(r + 2, k)
  28.       Rng1.Copy .Cells(r + 2, k + 1)
  29.    End With
  30.    k = IIf(k = 255, 1, k + 2)
  31.    r = IIf(k = 1, r + 18, r)
  32.    Else
  33.    MsgBox "無此除權資料"
  34. End If
  35. End With
  36. Next
  37. Application.ScreenUpdating = True
  38. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2011-3-23 18:22 | 顯示全部帖子
回復 8# candy516


    x = Application.Max(3, C.Row - 14)
是因為要算找到日期的位置往上14格的列號
若往上14格的列號只有<=3就要以3作為開始抓資料的列位
所以若你要抓30天資料這邊也要改
x = Application.Max(3, C.Row - 29)
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2011-3-26 16:33 | 顯示全部帖子
回復 17# candy516
  1. Sub ex()
  2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set sht = Sheets.Add(after:=Sheets(1))
  5. Application.ScreenUpdating = False
  6. With Sheet1
  7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  8.       mystr = A & "," & Left(A.Offset(, 1), 4)
  9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
  10.    Next
  11. End With
  12. k = 1: r = 1
  13. For Each ky In d.keys
  14. y = Split(ky, ",")(1)
  15. With Sheets(y)
  16. Set C = .Columns("A").Find(d(ky))
  17. Set B = .Rows(1).Find(Split(ky, ",")(0))
  18. If Not C Is Nothing And Not B Is Nothing Then
  19. x = Application.Max(3, C.Row - 14)
  20.    Set Rng = .Cells(x, 1).Resize(15, 1)
  21.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
  22.    With sht
  23.       Rng.Copy .Cells(r, k)
  24.       Rng1.Copy .Cells(r, k + 1)
  25.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
  26.    End With
  27.    r = r + 15
  28.    Else
  29.    MsgBox "無此除權資料"
  30. End If
  31. End With
  32. Next
  33. Application.ScreenUpdating = True
  34. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2011-3-27 22:55 | 顯示全部帖子
回復 20# candy516
  1. Sub ex()
  2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set sht = Sheets.Add(after:=Sheets(1))
  5. Application.ScreenUpdating = False
  6. With Sheet1
  7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  8.       mystr = A & "," & A.Offset(, 1)
  9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
  10.    Next
  11. End With
  12. k = 1: r = 1
  13. For Each ky In d.keys
  14. y = Left(Split(ky, ",")(1), 4)
  15. With Sheets(y)
  16. Set C = .Columns("A").Find(d(ky))
  17. Set B = .Rows(1).Find(Split(ky, ",")(0))
  18. If Not C Is Nothing And Not B Is Nothing Then
  19. x = Application.Max(3, C.Row - 5)
  20.    Set Rng = .Cells(x, 1).Resize(5, 1)
  21.    Set Rng1 = .Cells(x, B.Column).Resize(5, 1)
  22.    With sht
  23.       Rng.Copy .Cells(r, k)
  24.       Rng1.Copy .Cells(r, k + 1)
  25.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
  26.    End With
  27.    r = r + 5
  28.    Else
  29.    MsgBox "無此除權資料"
  30. End If
  31. End With
  32. Next
  33. Application.ScreenUpdating = True
  34. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2011-3-28 08:30 | 顯示全部帖子
回復 22# candy516


    可能有2種情況吧
  1. Sub ex()
  2. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set sht = Sheets.Add(after:=Sheets(1))
  5. Application.ScreenUpdating = False
  6. With Sheet1
  7.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  8.       mystr = A & "," & A.Offset(, 1)
  9.       d(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00"))
  10.       '若是直接用事件後第4天做搜尋值
  11.       'd(mystr) = DateValue(Format(A.Offset(, 1), "0000/00/00")) + 4
  12.    Next
  13. End With
  14. k = 1: r = 1
  15. For Each ky In d.keys
  16. y = Left(Split(ky, ",")(1), 4)
  17. With Sheets(y)
  18. Set C = .Columns("A").Find(d(ky))
  19. Set B = .Rows(1).Find(Split(ky, ",")(0))
  20. If Not C Is Nothing And Not B Is Nothing Then
  21. x = Application.Max(3, C.Row - 5)
  22.    '用事件日向上4格為目標
  23.    Set Rng = .Cells(x, 1)
  24.    Set Rng1 = .Cells(x, B.Column)
  25.    '直接用事件後第4天做搜尋值
  26.    'Set Rng = .Cells(C.Row, 1)
  27.    'Set Rng1 = .Cells(C.Row, B.Column)

  29.    With sht
  30.       Rng.Copy .Cells(r, k)
  31.       Rng1.Copy .Cells(r, k + 1)
  32.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
  33.    End With
  34.    r = r + 1 '只有一天資料所以只要加1
  35.    Else
  36.    MsgBox "無" & y & "年" & Split(ky, ",")(0) & "事件資料"
  37. End If
  38. End With
  39. Next
  40. Application.ScreenUpdating = True
  41. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2011-3-30 12:42 | 顯示全部帖子
回復 25# candy516
  1. Sub ex()
  2. On Error Resume Next
  3. Dim A As Range, B As Range, B1 As Range, B2 As Range, C As Range, Rng As Range, Rng1 As Range, d As Object
  4. Set d = CreateObject("Scripting.Dictionary")
  5. Set sht = Sheets.Add(after:=Sheets(1))
  6. Application.ScreenUpdating = False
  7. With Sheet1
  8.    For Each A In .Range(.[A2], .[A65536].End(xlUp))
  9.       mystr = A & "," & Left(A.Offset(, 1), 4)
  10.      '你Sheet1的A欄是以日期格式yyyy/m/d輸入，但格式設成yyyymmdd，所以，造成非全部為8碼
  11.    '用TEXT屬性得到所見字串
  12.       d(mystr) = DateValue(Format(A.Offset(, 1).Text, "0000/00/00"))
  13.       If Err.Number <> 0 Then MsgBox A & A.Offset(, 1)
  14.    Next
  15. End With
  16. k = 1: r = 1
  17. For Each ky In d.keys
  18. y = Split(ky, ",")(1)
  19. With Sheets(y)
  20. Set C = .Columns("A").Find(d(ky))
  21. Set B = .Rows(1).Find(Split(ky, ",")(0))
  22. If Not C Is Nothing And Not B Is Nothing Then
  23. x = Application.Max(3, C.Row - 14)
  24.    Set Rng = .Cells(x, 1).Resize(15, 1)
  25.    Set Rng1 = .Cells(x, B.Column).Resize(15, 1)
  26.    With sht
  27.       Rng.Copy .Cells(r, k)
  28.       Rng1.Copy .Cells(r, k + 1)
  29.       .Cells(r, 3) = y & "年第" & B.Column - 1 & "筆"
  30.    End With
  31.    r = r + 15
  32.    Else
  33.    MsgBox "無此除權資料"
  34. End If
  35. End With
  36. Next
  37. Application.ScreenUpdating = True
  38. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
8#
發表於 2011-3-31 18:32 | 顯示全部帖子
回復 28# candy516

正規化表格是根本解決之道
不過得要先擦完屁股喔

至於程式問題點是出在
Set C = .Columns("A").Find(d(ky), lookat:=xlWhole)
Set B = .Rows(1).Find(Split(ky, ",")(0), lookat:=xlPart)
加入搜尋參數就能正確找到資料了
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 2011-3-31 23:57 | 顯示全部帖子
回復 32# candy516

假如你這些資料是從系統中或網路Download的
這已經是既成表格，但是這樣的資料排列在資料庫原則中牴觸了一列為一筆資料的原則
這樣的表格你無法使用EXCEL內建的篩選功能或樞紐分析表
老夏前輩的檔案中你會發現是將所有年度的資料
依照日期、股票名稱、價格
一筆一筆地在同一工作表中呈現
這樣你就很輕易地使用樞紐分析或是以篩選功能獲得想要的資料
所以要把你的表格整理成跟老夏前輩一樣的資料表
你覺得你要花多少時間跟體力才能完成
所以，如果你是逐筆資料KEY的建立資料表時
那麼直接做成老夏前輩的格式，是不是就可以少掉這個整理程序
這就是我所說擦屁股啦!
老夏前輩不知道擦好沒?他說還在努力待續呢
學海無涯_不恥下問

TOP

        靜思自在 : 【行善要及時】行善要及時，功德要持續。如燒開水一般，未燒開之前千萬不要停熄火候，否則重來就太費事了。
返回列表 上一主題