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列と★との位置関係はかわらないものとします。
↑この部分がわかりづらかったかもしれません。申し訳ございませんが、
よろしくお願いします。
前回の仕様のままで、検索範囲をした場合です。
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
としてみてください。
ありがとうございます。どうもエラーがでるようでして、
下記にエクセルファイルの画像をのせておきましたので、一度ご覧いただけますでしょうか?(0913です)
http://photos.yahoo.co.jp/hatenasenyou19
お忙しい中ありがとうございます。