Excel VBA質問箱 IV

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

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


4433 / 76735 ←次へ | 前へ→

【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

0 hits

【77924】VBAによるデータ抽出等について 株太郎 16/2/13(土) 17:15 質問[未読]
【77925】Re:VBAによるデータ抽出等について β 16/2/13(土) 19:42 発言[未読]
【77926】Re:VBAによるデータ抽出等について マナ 16/2/14(日) 0:27 発言[未読]
【77927】Re:VBAによるデータ抽出等について β 16/2/14(日) 9:26 発言[未読]
【77929】Re:VBAによるデータ抽出等について マナ 16/2/14(日) 12:56 発言[未読]
【77931】Re:VBAによるデータ抽出等について 株太郎 16/2/14(日) 13:25 回答[未読]
【77935】Re:VBAによるデータ抽出等について マナ 16/2/14(日) 15:36 発言[未読]
【77936】Re:VBAによるデータ抽出等について 株太郎 16/2/14(日) 16:33 お礼[未読]
【77928】Re:VBAによるデータ抽出等について β 16/2/14(日) 9:36 発言[未読]
【77930】Re:VBAによるデータ抽出等について 株太郎 16/2/14(日) 13:07 回答[未読]
【77932】Re:VBAによるデータ抽出等について β 16/2/14(日) 14:07 発言[未読]
【77934】Re:VBAによるデータ抽出等について 株太郎 16/2/14(日) 15:30 お礼[未読]
【77933】Re:VBAによるデータ抽出等について β 16/2/14(日) 14:09 発言[未読]

4433 / 76735 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free