Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4432 / 76734

←次へ　｜　前へ→


	【77925】Re:VBAによるデータ抽出等について

β - 16/2/13(土) 19:42 -


	引用なし

	パスワード

▼株太郎さん：

株のことは詳しくないのですが、アップされたレイアウトと説明から推測して。
元シートが "Sheet1"、転記シートが "Sheet2" 。　
転記シート側のタイトルはあらかじめセットしてあるという前提です。

また、【赤】とか【青】ですけど、★印のところは、シート上に塗ってある実際の色番号に
直してください。

Sub Sample()
　　Dim red As Range
　　Dim blue As Range
　　Dim fR As Range
　　Dim fB As Range
　　Dim eR As Range
　　Dim eB As Range
　　Dim flagRB As Boolean
　　Dim f As Range
　　Dim e As Range
　　Dim c As Range
　　Dim pre As Range
　　Dim myColor As Long
　　Dim i As Long
　　Dim shT As Worksheet
　　
　　Set shT = Sheets("Sheet2")　　　'転記シート
　　i = 2　　　　　　　　　　　　　 '転記開始行番号
　　
　　With Sheets("Sheet1")　　　　　 '元シート
　　　　Set fR = .Range("D1")
　　　　Set fB = .Range("E1")
　　　　Set eR = .Range("D" & Rows.Count).End(xlUp)
　　　　Set eB = .Range("E" & Rows.Count).End(xlUp)
　　End With
　　
　　Do
　　　　flagRB = Not flagRB
　　　　If flagRB Then
　　　　　　Set f = fR
　　　　　　Set e = eR
　　　　　　myColor = vbRed　　 '★
　　　　Else
　　　　　　Set f = fB
　　　　　　Set e = eB
　　　　　　myColor = vbBlue　　'★
　　　　End If
　　　　
　　　　Application.FindFormat.Interior.Color = myColor
　　　　Set c = Range(f, e).Find(What:="", After:=f, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
　　　　If c Is Nothing Then Exit Do
　　　　
　　　　shT.Cells(i, "A").Value = c.EntireRow.Range("A1").Value　　　　 '日付
　　　　If flagRB Then
　　　　　　shT.Cells(i, "B").Value = c.EntireRow.Range("D1").Value　　 '高値
　　　　Else
　　　　　　shT.Cells(i, "C").Value = c.EntireRow.Range("E1").Value　　 '安値
　　　　End If
　　　　
　　　　If Not pre Is Nothing Then shT.Cells(i, "D").Value = c.Row - pre.Row
　　　　
　　　　i = i + 1
　　　　
　　　　
　　　　If c.Row = eR.Row Then Exit Do
　　　　
　　　　Set fR = c.EntireRow.Range("D1")
　　　　Set fB = c.EntireRow.Range("E1")
　　　　Set pre = c
　　Loop
　　　　
End Sub

5 hits

▼

【77924】VBAによるデータ抽出等について 株太郎 16/2/13(土) 17:15