1251521432 マクロ作成をお願いできますでしょうか?

K1に"お勧め文"とあり、K2に数式で入った文字列があります。

K2の式の結果の文字列には計算結果の値として、
[原産地]産の[果物]です。[売り1]です。ぜひお買い求めくださいませ。
というような文字列になります。

A1~J1、A10~J10、A13~J13、A16~J16、A19~J19、A22~J22(これらを★とします)に[原産地][果物][色][売り1]など[ ]でくくられたたくさんのフレーズがそれぞれ入っています。空白セルあり。[  ]でくくられた以外の数式文字列などは無視。

マクロをかけると、K2の中にある[ ]でくくられた同一フレーズのみを★の中にみつけ、その2行下の値(数式なら結果)に入れ替えK3に出力するマクロをお願いしたいのです。(K2の結果が出ないエラーなら空白)(★の2つ下の値に空白やエラーがあれば"■■"と出力)

なお、お勧め文は、25行下や53行下等(不規則)に多数あるとして、そのすべてを出力するようにしてほしいのです。ただし、K列と★との位置関係はかわらないものとします。
よろしくお願いします。

回答の条件
  • 1人2回まで
  • 登録:2009/08/29 13:50:34
  • 終了:2009/08/29 23:48:49

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/08/29 16:17:19

ポイント100pt

このような感じでしょうか。

仕様の誤解はコメントください。

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"))
        End If
    Next
End Sub

'--------------------------------------------------------
Function makeSentense(srcStr As String)
'--------------------------------------------------------
    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))
    Next
    makeSentense = srcStr
End Function

'--------------------------------------------------------
Function getWord(keyWord)
'--------------------------------------------------------
'--- ★定義範囲は下記の範囲
    Const KEYWORDS_RANGE = "A1:J1,A10:J10,A13:J13,A16:J16,A19:J19,A22:J22"
    getWord = "■■"
    
    Dim findWord As String
    findWord = Replace(Replace(keyWord, "[", ""), "]", "")
    
    Dim keyRange As Range
    Set keyRange = Range(KEYWORDS_RANGE).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
id:naranara19

ありがとうございます。画像のような形を出力すると、「■■産の■■です。■■です。■■。ぜひお買い求めくださいませ。」となってしまいます。画像のK2列ですが、画像だとそのまま値になっているように見えますが、数式でしてその関係でひっぱってこれないのでしょうか?また、2行下の値も数式のときもあれば、そのまま文字列のこともあります。その点も影響しているのでしょうか?素人で本当にご迷惑をおかけします。ご回答いただいたことに大変感謝しております。

2009/08/29 17:27:52

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/08/29 16:17:19ここでベストアンサー

ポイント100pt

このような感じでしょうか。

仕様の誤解はコメントください。

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"))
        End If
    Next
End Sub

'--------------------------------------------------------
Function makeSentense(srcStr As String)
'--------------------------------------------------------
    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))
    Next
    makeSentense = srcStr
End Function

'--------------------------------------------------------
Function getWord(keyWord)
'--------------------------------------------------------
'--- ★定義範囲は下記の範囲
    Const KEYWORDS_RANGE = "A1:J1,A10:J10,A13:J13,A16:J16,A19:J19,A22:J22"
    getWord = "■■"
    
    Dim findWord As String
    findWord = Replace(Replace(keyWord, "[", ""), "]", "")
    
    Dim keyRange As Range
    Set keyRange = Range(KEYWORDS_RANGE).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
id:naranara19

ありがとうございます。画像のような形を出力すると、「■■産の■■です。■■です。■■。ぜひお買い求めくださいませ。」となってしまいます。画像のK2列ですが、画像だとそのまま値になっているように見えますが、数式でしてその関係でひっぱってこれないのでしょうか?また、2行下の値も数式のときもあれば、そのまま文字列のこともあります。その点も影響しているのでしょうか?素人で本当にご迷惑をおかけします。ご回答いただいたことに大変感謝しております。

2009/08/29 17:27:52
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/08/29 16:57:08

ポイント30pt

こんな感じでどうでしょうか。

Sub Macro()
    Dim str As String
    Dim p1 As Integer
    Dim p2 As Integer
    Dim f As Boolean
    Dim i As Long
    
    i = 1
    While i < ActiveSheet.UsedRange.Rows.Count
        str = Cells(i + 1, "K").Value
        
        p1 = InStr(1, str, "[")
        p2 = InStr(p1, str, "]")
        f = False
        While p1 > 0 And p2 > 0
            If serchWord(ActiveSheet.Range(Cells(i, "A"), Cells(i + 23, "I")), Mid(str, p1, p2 - p1 + 1)) <> "" Then
                str = Replace(str, Mid(str, p1, p2 - p1 + 1), serchWord(ActiveSheet.Range(Cells(i, "A"), Cells(i + 23, "I")), Mid(str, p1, p2 - p1 + 1)))
            Else
                f = True
            End If
            p1 = InStr(p2, str, "[")
            If p1 > 0 Then
                p2 = InStr(p1, str, "]")
            End If
        Wend
        If f Then
            str = ""
        End If
        ActiveSheet.Cells(i + 2, "K").Value = str
        i = i + 25
    Wend
End Sub

Function serchWord(r As Range, key As String) As String
    Dim r2 As Range
    Set r2 = r.Find(key, LookAt:=xlWhole)
    If Not r2 Is Nothing Then
        If IsError(r2.Offset(2, 0).Value) Then
            serchWord = "■■"
        Else
            If r2.Offset(2, 0).Value = "" Then
                serchWord = "■■"
            Else
                serchWord = r2.Offset(2, 0).Value
            End If
        End If
    Else
        serchWord = ""
    End If
End Function
id:naranara19

いつもありがとうございます。マクロですが、実行しましたところ、どうも下2行がうまくよみとれていないときに[果物]などとそのままあらわれてしまうようです。G3のセルは、実は、「=IF(ISERROR(VLOOKUP(G2,$R$2:$T$1000,2,0)),"",VLOOKUP(G2,$R$2:$T$1000,2,0))」というような式になっておりまして、計算結果ではオレンジなのですが、これを[果物]と読みこんでおります。それはそうと、SALINGERさんにどれだけ助けていただいたことか。本当にいつも感謝しております。

2009/08/29 17:37:32
  • id:Mook
    勘違いしていました。

    検索キーワードにも[ ]がついているのですね。
      findWord = Replace(Replace(keyWord, "[", ""), "]", "")

      findWord = keyWord
    にしてください。
  • id:SALINGER
    数式でも使っているのは値なので、これでいいとおもうのですが。
    たぶん、"["と"]"が全角と半角で違っていることはないでしょうか。
  • id:naranara19
    MOOKさんへ
    改造してくれたパターンで変更いたしましたら、うまくいきました!本当にありがとうございました。これからもどうぞよろしくお願いいたします。

    SALINGERさんへ
    いつもありがとうございます。半角全角を再度見直して、置換により入れ替えても見たのですが、やはり[アイテム]が拾えませんでした。それにしても毎回毎回ありがとうございます。今回はポイント設定が少なすぎて失礼しました。これからもどうぞよろしくお願いいたします。

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません