質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.04%

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

解決済

回答 2

投稿

  • 評価
  • クリップ 2
  • VIEW 6,025

score 14

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

マンションのデータをまとめたいため、スーモのサイトからエクセルにコピペしました。
元データ
イメージ説明
この状態から
sheet3のこれに整理していく
イメージ説明
やりたい条件としては、
・A列を「チェック」で検索→ヒットしたセルの3個下のセルの内容をマンション名列に入れる
・販売価格で検索→ヒットしたセルのひとつ下のセルの内容を販売価格列に入れる

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

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

よろしくお願いいたします。
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

0

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

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/09/04 18:18

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

    キャンセル

  • 2015/09/04 20:04

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

    キャンセル

0

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

-----
決め打ちしている事
・データは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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2015/09/04 11:34

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

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

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.04%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る