id:naranara19
ポイントあり130ptベストアンサーあり
コンピュータ科学・統計資料

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

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

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

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

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

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

回答の条件
  • 1人2回まで
  • 登録：
  • 終了：2009/08/29 23:48:49
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Mook No.1

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

ポイント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

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

2009/08/29 17:27:52

その他の回答（1件）

id:Mook No.1

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

ポイント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

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

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

回答回数3454ベストアンサー獲得回数969

ポイント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

いつもありがとうございます。マクロですが、実行しましたところ、どうも下２行がうまくよみとれていないときに[果物]などとそのままあらわれてしまうようです。G３のセルは、実は、「=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

コメント（3件)

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

    検索キーワードにも[ ]がついているのですね。
    　　findWord = Replace(Replace(keyWord, "[", ""), "]", "")
    を
    　　findWord = keyWord
    にしてください。
  • id:SALINGER
    SALINGER 2009/08/29 17:56:57
    数式でも使っているのは値なので、これでいいとおもうのですが。
    たぶん、"["と"]"が全角と半角で違っていることはないでしょうか。
  • id:naranara19
    リセール京都買取 2009/08/29 23:42:46
    MOOKさんへ
    改造してくれたパターンで変更いたしましたら、うまくいきました！本当にありがとうございました。これからもどうぞよろしくお願いいたします。

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

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

トラックバック

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

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

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ