セルの文字連結マクロ作成にお付き合いください。


D列には特定の言葉が入っています。
I列に1セル1500文字程度の文章が入っています。空白の場合もあります。
I列の文字列の中には、[りんご]など、[ ]でくくられた文字がいくつかあります。

マクロをかけると、BZ列に平行に、D列の言葉+[ ]でくくられた文字がすべてコピー⇒つなげて貼付されるようにしてほしいのです。

例・(1行目は見出しのため何もしない)
D列
2果物
3空白
4オレンジ

I列
2[りんご]はとにかく[おいしい]です。
3空白セル
4この[みかん]は送料無料です。

↓マクロをかけると
BZ列
2果物りんごおいしい
3空白のまま
4オレンジみかん

となります。3行目のように抜き出すものがないのときは何もしないとしてほしいです。50行目までいってマクロが止まります。また、BZ列(D列やI列も)は多少列を動かすこともありますので、BX列なら、この数字の4を3に直すとかそのあたりも教えてくださると助かります。

よろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 登録:2009/10/25 15:09:34
  • 終了:2009/10/25 20:13:34

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/10/25 16:00:11

ポイント50pt

コードの最初のところの定数を変更することで、最終行、各列を変更できます。

Sub test()
    Const lastRow As Long = 50
    Const retu1 As String = "D"
    Const retu2 As String = "I"
    Const retu3 As String = "BZ"
    
    Dim r As Long
    Dim str As String
    Dim str2 As String
    Dim stP As Integer
    Dim edP As Integer
    
    For r = 2 To lastRow
        If Cells(r, retu1).Value <> "" Then
            str = ""
            str2 = Cells(r, retu2).Value
            stP = 1
            Do
                stP = InStr(stP, str2, "[")
                If stP = 0 Then Exit Do
                edP = InStr(stP, str2, "]")
                If edP = 0 Then Exit Do
                str = str & Mid(str2, stP + 1, edP - stP - 1)
                stP = edP
            Loop
            Cells(r, retu3).Value = Cells(r, retu1).Value & str
        End If
    Next r
End Sub
id:naranara19

いつもありがとうございます!

Const lastRow As Long = 50

Const retu1 As String = "D"

Const retu2 As String = "I"

Const retu3 As String = "BZ"

が大変分かりやすく、素人の私にぴったりでした。なおかつ一番のご回答に本当に感謝します。ありがとうございます!

2009/10/25 20:09:42

その他の回答(3件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/10/25 16:00:11ここでベストアンサー

ポイント50pt

コードの最初のところの定数を変更することで、最終行、各列を変更できます。

Sub test()
    Const lastRow As Long = 50
    Const retu1 As String = "D"
    Const retu2 As String = "I"
    Const retu3 As String = "BZ"
    
    Dim r As Long
    Dim str As String
    Dim str2 As String
    Dim stP As Integer
    Dim edP As Integer
    
    For r = 2 To lastRow
        If Cells(r, retu1).Value <> "" Then
            str = ""
            str2 = Cells(r, retu2).Value
            stP = 1
            Do
                stP = InStr(stP, str2, "[")
                If stP = 0 Then Exit Do
                edP = InStr(stP, str2, "]")
                If edP = 0 Then Exit Do
                str = str & Mid(str2, stP + 1, edP - stP - 1)
                stP = edP
            Loop
            Cells(r, retu3).Value = Cells(r, retu1).Value & str
        End If
    Next r
End Sub
id:naranara19

いつもありがとうございます!

Const lastRow As Long = 50

Const retu1 As String = "D"

Const retu2 As String = "I"

Const retu3 As String = "BZ"

が大変分かりやすく、素人の私にぴったりでした。なおかつ一番のご回答に本当に感謝します。ありがとうございます!

2009/10/25 20:09:42
id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012009/10/25 16:31:11

ポイント35pt
Sub Macro1()
    Dim exp As Object, mat
    Dim r As Integer, t As String
    Set exp = CreateObject("VBScript.RegExp")
    With exp
        .Pattern = "\[(.+?)\]": '検索パターン
        .IgnoreCase = True: '大文字と小文字は区別しない事とする
        .Global = True: '文字列全体を対象とする
        For r = 2 To 50: '2行目から50行目まで
            t = Trim(Cells(r, 4)): 'D列
            Set mat = .Execute(Cells(r, 9)): 'I列
            For c = 0 To mat.Count - 1
                t = t & mat(c).SubMatches(0)
            Next
            If t <> "" Then
                Cells(r, 78).Value = t: 'BZ列
            End If
        Next r
    End With
End Sub

BZ列の計算は

  26 * 2 + 26 = 78

CA列だと

  26 * 3 + 1 = 79

といった具合に計算。

id:naranara19

はじめまして。こちらも完ぺきに動きました!ご回答に深く感謝します。助かります。

2009/10/25 20:10:13
id:HALSPECIAL No.3

HALSPECIAL回答回数407ベストアンサー獲得回数862009/10/25 16:35:54

ポイント20pt

ユーザー定義関数はいかがでしょう。


標準モジュールに以下の関数を記述します。

セルに、

=ユーザ関数(D2,I2)

等の数式を入れてください。

Option Explicit

Public Function ユーザ関数(ByVal cell1 As Range, ByVal cell2 As Range) As String

    Dim oRe, oMatch, oMatches
    Dim result As String
  
    Set oRe = CreateObject("VBScript.RegExp")
    With oRe
        .Global = True
        .IgnoreCase = True
    End With

    oRe.Pattern = "\[(.+?)\]"
    Set oMatches = oRe.Execute(cell2.Value)
    For Each oMatch In oMatches
        Set oMatches = oMatch.SubMatches
        result = result & oMatches.Item(0)
    Next

    Set oMatches = Nothing
    Set oMatch = Nothing
    Set oRe = Nothing

    ユーザ関数 = cell1.Value & result

End Function

id:naranara19

ご丁寧にありがとうございます。スキル不足でいまひとつ理解できませんでした。実行しようとすると、マクロを聞いてきてしまいますが、ただ単に私の設定が悪いかと思います。私のためにご回答ありがとうございました。

2009/10/25 20:11:06
id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912009/10/25 17:13:13

ポイント35pt

すでに回答はありますが、正規表現を使用した例です(これも回答されているとは思いますが)。

前回のご質問の関連と思いましたので、遅れ馳せながら回答いたしました。


対象列の変更は先頭の部分で変更してください。

Sub joninWords()
    Const preCol = "D"  '--- 前につける列
    Const pstCol = "I"  '--- [] を検索する列
    Const resCol = "BZ" '--- 結果を格納する列

    Dim re
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Pattern = "\[.*?\]"      '検索パターンを設定
        .Global = True         '文字列全体を検索
    End With
    
    Dim r As Long
    Dim res As String
    Dim matches, mc
    For r = 1 To 50  '--- 処理する行
        Set matches = re.Execute(Cells(r, pstCol).Value)
        res = Cells(r, preCol)
        For Each mc In matches
            res = res & Mid(mc.Value, 2, Len(mc.Value) - 2)
        Next
        Cells(r, resCol).Value = res
    Next r
    Set re = Nothing
End Sub
id:naranara19

いつもありがとうございます。Mookさんと、SALINGERさんにはいつも助けられっぱなしです。本当に感謝しております。完璧に動作いたしました。

2009/10/25 20:12:07
  • id:HALSPECIAL
    HALSPECIAL 2009/10/25 21:59:40
    マクロの実行はしません。
    ワークシート関数のように、セルに数式として、
    =ユーザ関数(D2,I2)
    を入れればいいのです。


    メリットは、
    セル位置の変更に対する自由度があるのと、
    セル内容を変更した際に即座に関数が機能することです。
    デメリットは、
    自動計算になっている場合、
    ブックを開くたびに計算されることです。
  • id:naranara19
    びっくりしました。しっかりと動きました。
    素人過ぎて失礼しました。

    ポイントをお渡しできていてよかったです。
    (少なくてすみませんでした)

    新たな視点をありがとうございます。大変助かりました。
    アフターフォローに深く感謝します。

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

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

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

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