人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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に直すとかそのあたりも教えてくださると助かります。

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


●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:BX はと みかん りんご オレンジ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● SALINGER
●50ポイント ベストアンサー

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

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
◎質問者からの返答

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

Const lastRow As Long = 50

Const retu1 As String = "D"

Const retu2 As String = "I"

Const retu3 As String = "BZ"

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


2 ● kn1967
●35ポイント
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

といった具合に計算。

◎質問者からの返答

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


3 ● HALSPECIAL
●20ポイント

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


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

セルに、

=ユーザ関数(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

◎質問者からの返答

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


4 ● Mook
●35ポイント

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

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


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

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
◎質問者からの返答

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ