【マクロ】検索に一致した条件とその下のセルを抽出

Question

エクセルマクロで質問です。
マクロを学びたいため、例のマクロを教えていただきたいです。

マンションのデータをまとめたいため、スーモのサイトからエクセルにコピペしました。
元データ

この状態から
sheet3のこれに整理していく

やりたい条件としては、
・A列を「チェック」で検索→ヒットしたセルの３個下のセルの内容をマンション名列に入れる
・販売価格で検索→ヒットしたセルのひとつ下のセルの内容を販売価格列に入れる

・・・・くりかえしです。

必要な項目だけを抜き出して整理するマクロを作りたいです。

よろしくお願いいたします。

Answer 1

こんにちは。

コメントではコードを貼り付けにくいので、新規でおこしました。

相対位置を指示する形式では期待する結果を得られないとの事でしたので、
検索をする方法に切り替えて書いてみました。

Sample()の中に全て書くとかなり冗長になってしまったので、一つ関数を作っています。
Sample()を実行して確認をしてもらえればと思います。

決め打ちの事項については、前回の物から「相対位置が同じ」と「データの1固まりが30行」を
除外したくらいです。

後、データの1固まり(「チェック」から次の「チェック」まで)で、取得する情報(販売価格など)が
ヒットしなかった場合は空""となります。(マンション名は除く)

Option Explicit

'keyword   : 検索する項目名
'rng       : 検索範囲
'offsetRow : 値が格納されている行(検索ヒット場所からの相対位置)
'offsetCol : 値が格納されている列(検索ヒット場所からの相対位置)
Function GetItemText(keyword As String, rng As Range, offsetRow As Long, offsetCol As Long) As String
  On Error Resume Next

  Dim MatchResult As Variant
  Dim value As String
  
  value = ""
  
  '検索の実行
  MatchResult = Application.Match(keyword, rng, 0)
  
  If IsNumeric(MatchResult) Then
    value = rng.Cells(CLng(MatchResult) + offsetRow, 1 + offsetCol).Text 'ヒットすれば結果をvalueへ
  End If
  
  GetItemText = value
End Function


Sub Sample()

  Dim DataSht As Worksheet
  Dim PutSht As Worksheet
  Dim DataEndRow As Long
  Dim BlockStartRow As Long
  Dim BlockNextRow As Long
  Dim PutRow As Long
  Dim RngStr As String
  Dim MatchResult As Variant

  'データ出力開始位置
  Const PUT_START = 4
  
  'データ開始と取得情報のキーワード
  Const KEYWORD_MANSION = "チェック"
  Const KEYWORD_PRICE = "販売価格"
  Const KEYWORD_LOCATION = "所在地"
  Const KEYWORD_STATION = "沿線・駅"
  Const KEYWORD_AREA = "占有面積"
  Const KEYWORD_FLOOR = "間取り"
  Const KEYWORD_BUILT = "築年月"
  

  Set DataSht = Sheet2 '元のデータが入っているシート
  Set PutSht = Sheet3  '取得した情報を出力するシート
  
  
  ' データの入っている最終行を取得(A列)
  DataEndRow = DataSht.Cells(Rows.Count, 1).End(xlUp).Row
  
  '先頭の「チェック」位置を取得
  RngStr = "A1:A" + CStr(DataEndRow)
  MatchResult = Application.Match(KEYWORD_MANSION, DataSht.Range(RngStr), 0)
  If IsError(MatchResult) Then
    MsgBox "該当データが1つも存在しません"
    Exit Sub
  End If
  BlockStartRow = CLng(MatchResult)
  
  '出力開始位置で初期化
  PutRow = PUT_START
  
  
  Do While BlockStartRow < DataEndRow
    
    '次の「チェック」を検索
    RngStr = "A" + CStr(BlockStartRow + 1) + ":A" + CStr(DataEndRow) '検索範囲の文字列を生成
    MatchResult = Application.Match(KEYWORD_MANSION, DataSht.Range(RngStr), 0)
    If IsError(MatchResult) Then
      BlockNextRow = DataEndRow + 1 '次の「チェック」が存在しない
    Else
      BlockNextRow = BlockStartRow + CLng(MatchResult)
    End If

    'マンション名が「チェック」の3行下なので、少なくともデータの1固まりは4行が必要
    If BlockNextRow - BlockStartRow >= 4 Then
    
      '----- A列に存在する情報の取得 -----
      RngStr = "A" + CStr(BlockStartRow) + ":A" + CStr(BlockNextRow - 1) '検索範囲
      
      'マンション名の取得(A列)
      PutSht.Cells(PutRow, 1) = DataSht.Cells(BlockStartRow + 3, 1).Text
      
      '販売価格の取得(A列)
      PutSht.Cells(PutRow, 2) = GetItemText(KEYWORD_PRICE, DataSht.Range(RngStr), 1, 0)
      
      '所在地の取得(A列)
      PutSht.Cells(PutRow, 3) = GetItemText(KEYWORD_LOCATION, DataSht.Range(RngStr), 1, 0)
      
      '沿線・駅の取得(A列)
      PutSht.Cells(PutRow, 4) = GetItemText(KEYWORD_STATION, DataSht.Range(RngStr), 1, 0)
    
      '占有面積の取得(A列)
      PutSht.Cells(PutRow, 5) = GetItemText(KEYWORD_AREA, DataSht.Range(RngStr), 1, 0)


      '----- B列に存在する情報の取得 -----
      RngStr = "B" + CStr(BlockStartRow) + ":B" + CStr(BlockNextRow - 1) '検索範囲
      
      '間取りの取得(B列)
      PutSht.Cells(PutRow, 6) = GetItemText(KEYWORD_FLOOR, DataSht.Range(RngStr), 1, 0)

      '築年月の取得(B列)
      PutSht.Cells(PutRow, 7) = GetItemText(KEYWORD_BUILT, DataSht.Range(RngStr), 1, 0)

      PutRow = PutRow + 1
    End If
    
    BlockStartRow = BlockNextRow
  Loop
  
  MsgBox "データの取得を完了しました"
End Sub

Comments

[hirory]

完璧でした！本当にありがとうございます！
これをたたき台にして今後勉強していこうと思います。
お忙しい中本当にありがとうございました。

[sgr-2]

上手くいったようで良かったです。
Excelは「マクロの記録」が とても強力なので、これを追うだけでもVBA(特にExcel固有の機能)など効率的に勉強できると思います。
# 私は「マクロの記録」に随分助けられました。

Answer 2

こんばんは。
サンプルのコードを書くにあたり、かなり決め打ちしている部分があり
期待した方法と異なるかもしれませんが、以下のコードではいかがでしょうか。

---

決め打ちしている事
・データはSheet2に存在し、取得したデータはSheet3に出力する
・「チェック」が1固まりのデータの開始を示す(これは例の通りと思います)
・「チェック」は必ずA列に存在する
・取得対象の「間取り」と「築年月」はB列、それ以外はA列に存在する
・取得する情報(マンション名、販売価格など)はすべて「チェック」からの相対位置が同じ
→項目毎に検索しないで、チェックからの相対位置を使って取得
・スクリーンショットの通り、「チェック」から終端?「ロビー」までが30行なので
データの1固まりは30行あるとする
→コード中の「BLOCK_SIZE_ROW」がそれにあたります、30行より小さい可能性がある場合は
1固まりの最小となる行数を指定します

方法はいくらかあると思います。検索(Findコマンドなど)を使わないで、走査していく方が単純で
分かり易いと考えました。

データの固まりと固まりの間に多くの空行が存在するような形でなければ、走査する方法であっても

そんなに効率は悪くないと思います。

Option Explicit

Sub Sample()
  
  Dim DataSht As Worksheet
  Dim PutSht As Worksheet
  Dim DataEndRow As Long
  Dim ReadRow As Long
  Dim ReadCol As Long
  Dim PutRow As Long

  'データ走査開始位置
  Const START_ROW = 1
  Const START_COL = 1
  
  'データ出力開始位置
  Const PUT_START = 4
  
  Const KEYWORD = "チェック"
  
  '各項目の「チェック」からの相対位置
  Const MANSION_OFFSET_ROW = 3   'マンション名
  Const MANSION_OFFSET_COL = 0
  Const PRICE_OFFSET_ROW = 10    '販売価格
  Const PRICE_OFFSET_COL = 0
  Const LOCATION_OFFSET_ROW = 12 '所在地
  Const LOCATION_OFFSET_COL = 0
  Const STATION_OFFSET_ROW = 14  '沿線・駅
  Const STATION_OFFSET_COL = 0
  Const AREA_OFFSET_ROW = 16     '占有面積
  Const AREA_OFFSET_COL = 0
  Const FLOOR_OFFSET_ROW = 16    '間取り
  Const FLOOR_OFFSET_COL = 1
  Const BUILT_OFFSET_ROW = 18    '築年月
  Const BUILT_OFFSET_COL = 1
  
  Const BLOCK_SIZE_ROW = 30      'データ1固まりの行数
  

  Set DataSht = Sheet2 '元のデータが入っているシート
  Set PutSht = Sheet3  '取得した情報を出力するシート
  
  ' データの入っている最終行を取得(A列)
  DataEndRow = DataSht.Cells(Rows.Count, 1).End(xlUp).Row
  
  '走査開始位置で初期化
  ReadRow = START_ROW
  ReadCol = START_COL
  
  '出力開始位置で初期化
  PutRow = PUT_START
  
  Do While ReadRow < DataEndRow
    If DataSht.Cells(ReadRow, ReadCol).Text = KEYWORD Then
    
      With DataSht
        'マンション名の取得
        PutSht.Cells(PutRow, 1) = .Cells(ReadRow + MANSION_OFFSET_ROW, ReadCol + MANSION_OFFSET_COL).Text
        
        '販売価格の取得
        PutSht.Cells(PutRow, 2) = .Cells(ReadRow + PRICE_OFFSET_ROW, ReadCol + PRICE_OFFSET_COL).Text
        
        '所在地の取得
        PutSht.Cells(PutRow, 3) = .Cells(ReadRow + LOCATION_OFFSET_ROW, ReadCol + LOCATION_OFFSET_COL).Text
        
        '沿線・駅の取得
        PutSht.Cells(PutRow, 4) = .Cells(ReadRow + STATION_OFFSET_ROW, ReadCol + STATION_OFFSET_COL).Text
        
        '占有面積の取得
        PutSht.Cells(PutRow, 5) = .Cells(ReadRow + AREA_OFFSET_ROW, ReadCol + AREA_OFFSET_COL).Text
        
        '間取りの取得
        PutSht.Cells(PutRow, 6) = .Cells(ReadRow + FLOOR_OFFSET_ROW, ReadCol + FLOOR_OFFSET_COL).Text
        
        '築年月の取得
        PutSht.Cells(PutRow, 7) = .Cells(ReadRow + BUILT_OFFSET_ROW, ReadCol + BUILT_OFFSET_COL).Text
        
      End With
      ReadRow = ReadRow + BLOCK_SIZE_ROW
      PutRow = PutRow + 1
      
    Else
      ReadRow = ReadRow + 1
    End If
  Loop
End Sub

Comments

[hirory]

うまくいきました！本当にありがとうございます！！！
ただ、ところどころ空白行数が違い、チェックからの相対位置が異なります。

文字を検索して、その下を抽出するという方法はありますでしょうか？

お手すきの時間にお教えいただきたいです。