前回質問したものです。

http://q.hatena.ne.jp/1251521432

できればMookさんにお願いできたら幸いです。

A1~J1、A10~J10、A13~J13、A16~J16、A19~J19、A22~J22(これらを★とします)

なのですが、25行下の、K28にもK3と同内容が入ることに気づきました。
たぶん仕様を誤って伝えていたかと思います。申し訳ありません。

私がしていただきたいのは、
K28に入る場合は、
★も25行下のところから抜き出して対応してもらいたいのです。
つまり参照元の対象は★から25行下ですので、
A26~J26、A35~J35、A38~J38、A41~J41、A44~J44、A47~J47
です。

K53はA51~J51・・・A72~J72という感じで、K78以下も同様です。

【前提】K列と★との位置関係はかわらないものとします。
↑この部分がわかりづらかったかもしれません。申し訳ございませんが、
よろしくお願いします。

回答の条件
  • 1人5回まで
  • 登録:
  • 終了:2009/09/14 00:11:58
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Mook No.1

回答回数1314ベストアンサー獲得回数393

ポイント80pt

前回の仕様のままで、検索範囲をした場合です。

Option Explicit

'--------------------------------------------------------
' K 列のお勧め文を処理
'--------------------------------------------------------
Sub main()
'--------------------------------------------------------
    Dim lastRow As Long
    lastRow = Range("K" & Rows.Count).End(xlUp).Row

    Dim i As Long
    For i = lastRow - 1 To 1 Step -1
        If Cells(i, "K") = "お勧め文" Then
           Cells(i + 2, "K") = makeSentense(Cells(i + 1, "K"), i)
        End If
    Next
End Sub

'--------------------------------------------------------
Function makeSentense(srcStr As String, baseRow As Long)
'--------------------------------------------------------
    Dim RegExp As Object
    Dim Match As Object
    Set RegExp = CreateObject("VBScript.RegExp")
'--- [****] を検索
    RegExp.Pattern = "\[[^(\[\])]+\]"
    RegExp.Global = True      '複数マッチを有効にする
    For Each Match In RegExp.Execute(srcStr)
        srcStr = Replace(srcStr, Match.Value, getWord(Match.Value, baseRow - 1))
    Next
    makeSentense = srcStr
End Function

'--------------------------------------------------------
Function getWord(findWord, offsetRow As Long)
'--------------------------------------------------------
'--- ★定義範囲は下記の範囲
    Const KEYWORDS_BASE_RANGE = "A1:J1,A10:J10,A13:J13,A16:J16,A19:J19,A22:J22"
    getWord = "■■"
        
    Dim keyRange As Range
    Set keyRange = Range(KEYWORDS_BASE_RANGE).Offset(offsetRow, 0).Find(What:=findWord, lookat:=xlWhole)
    
    If keyRange Is Nothing Then Exit Function
    If IsError(keyRange.Offset(2, 0)) Then Exit Function
    If keyRange.Offset(2, 0) = "" Then Exit Function

    getWord = keyRange.Offset(2, 0).Value
End Function

もし単純に25行ごとに処理をしたいばあい、先頭の部分を

'--------------------------------------------------------
Sub main()
'--------------------------------------------------------
    Dim lastRow As Long
    lastRow = Range("K" & Rows.Count).End(xlUp).Row

    Dim i As Long
    For i = 1 To lastRow Step 25
        Cells(i + 2, "K") = makeSentense(Cells(i + 1, "K"), i)
    Next
End Sub

としてみてください。

id:naranara19

ありがとうございます。どうもエラーがでるようでして、

下記にエクセルファイルの画像をのせておきましたので、一度ご覧いただけますでしょうか?(0913です)

http://photos.yahoo.co.jp/hatenasenyou19

お忙しい中ありがとうございます。

2009/09/13 22:39:38
  • id:Mook
    仕様の確認ですが★の全体の位置関係は、下に移動するだけでセル数等は変わらない
    と考えてよいということですか?
  • id:naranara19
    Mookさん、いつもすみません。助かります。はい、セルは25個下ずつずれるということに決めました。1個目、2個目と枠組みの構成(位置関係)だけはかわらず、[ ]の中の言葉が変ることがあるということでお願いします。
  • id:Mook
    再確認ですが、K列に「お勧め文」があるところを基準に(これが25行ごと?)処理を
    するのでしょうか。

    それとも「お勧め文」は無視して25行ごとということですか?
  • id:naranara19
    ありがとうございます。K列のお勧め文は毎度ございます。その1行下を参照し、2行下に出力するようにお願いします。

    下記にエクセルファイルの画像をのせておきましたので、一度ご覧いただけますでしょうか?(0912です)
    http://photos.yahoo.co.jp/hatenasenyou19


    A1~J24までがひとくくりで、それをK3に。
    (読む範囲は、A1~J1、A10~J10、A13~J13、A16~J16、A19~J19、A22~J22)

    A26~J49までもひとくくりで、それをK28に。
    (読む範囲は、A26~J26、A35~J35、A38~J38、A41~J41、A44~J44、A47~J47)

    まったく同じ位置関係で、25行ずつ下に、続いていきます(増やしたいので、25行下になければストップする形でお願いできたら幸いです)

    お勧め文は無視してくださってもかまいません。(25行ずつと決めましたので。一応残しておく形といたします)

    よろしくお願い申し上げます。
  • id:Mook
    エラーの状況を教えていただけますか。
    デバッグモードで黄色くなっている位置と、その時の変数の値などわかるとよいです。
    画像を見てみると、K27 等が空欄のように見えますが、これは通常あり得る状態ですか?


    推測ですが、空白文対策として

      If Cells(i, "K") = "お勧め文" Then
        Cells(i + 2, "K") = makeSentense(Cells(i + 1, "K"), i)
      End If

      If Cells(i, "K") = "お勧め文" Then
        If Cells(i + 1, "K") <> "" Then
          Cells(i + 2, "K") = makeSentense(Cells(i + 1, "K"), i)
        End If
      End If
    としてみてどうでしょうか。
  • id:naranara19
    Mookさんへ

    何度もお付き合いいただきまして、ありがとうございました。
    しっかりと動きました!!

    細かい仕様が非常に大事だということが再確認できました。
    本当にお手数をおかけしてすみませんでした。

    今後もぜひお助けくださいませ。
    本当に助かっております。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません