エクセルのマクロを使って、データをまとめる方法を教えてください

質問

最近関数を使い始めたエクセル初心者です。
会社でまとめてくれと、数年分の会議出席者のエクセルファイルを渡されたのですが、うまくマクロが作れず困っています。
マクロが分かる方、教えて頂けないでしょうか。
どうかよろしくお願いいたします。

１．データの内容は、大きく分けると「会議名」 「出席者の役職or所属」 「氏名」で構成されています。
２．データは、エクセルの１列（Ａ列）だけを使って縦に延々と入力されています。
３．一つの文章は、基本的に１つのセルに入っています。
　　（横に長い文章はたまに下のセルに入力されています）
４．会議毎に２行ずつ行を空けています。
５．役職と氏名の区切り方は、"（ ）" もしくは "、"　になっています。
６．人と人との区切り方は、"▲"になっています

【元のデータ】
｜　　　　　　　　　　　　←Ａ列→　　　　　　　　　　　　｜
*************************************************************
品質改善定例会（会議概要）2007/03/24""会議室　B""

　品質改善定例会
　（３月２４日午前１０時）品質保証担当（開発本部長）日本太郎▲事業企画、日本太郎

臨時営業戦略会議（会議概要）2007/03/24""会議室　A""

　月例営業戦略会議
　（３月２４日午後２時）営業本部長（国内営業）日本太郎▲営業管理、日本太郎
　関東・北陸営業本部長、日本太郎▲総合企画（営業本部販売推進）日本太郎
************************************************************

　　　　　　　　　　　　　　↓

【このようにまとめたいです】
｜　←Ａ列→　｜　　　　　←Ｂ列→　　　　｜　←Ｃ列→　｜
　　会議名　　　　　　役職名　　　　　　　　　　氏名　　　　　　
***********************************************************
品質改善定例会 品質保証担当（開発本部長） 日本太郎
品質改善定例会 事業企画 　日本太郎
月例営業戦略会議 営業本部長（国内営業） 日本太郎
月例営業戦略会議 営業管理（営業副本部長） 日本太郎
月例営業戦略会議 関東・北陸営業本部長 日本太郎
月例営業戦略会議 総合企画（営業本部販売推進）日本太郎
************************************************************

回答No.11

Wendy02 · ベストアンサー

こんばんは。

>本当は、最初から全部出せればよいのですが、文字数に制限がありすいません。※（）は予め全て半角に直しました。

どちらでも構いませんが、初期設定では、丸括弧は、「全角」という前提になっています。「半角」にしても、プログラム上で、全角に戻ってしまいます。

　If Len(c.Value) > 0 And InStr(1, c.Value, "（会議概要）", vbTextCompare) > 1 Then
　　　　　　n = Mid(Trim(c.Value), 1, InStr(1, c.Value, "（", vbTextCompare) - 1)
　　　　　　k = k + 1
　'ElseIf Len(Trim(c.Value)) > 0 And k > 4 Then　　●この部分
　'　　n = ""　　　'●この部分..この二つの行を、コメントブロックします。
　　End If

*コメントブロックというのは、コメントの前に「'（アポストロフィ）」を付けることです。

なお、私は、アクセスのタイムリミットがありますので、当分、アクセスできなくなる予定です。hige_082さんの#10のコードで完成しても構わないです。

この種のものは正規表現で可能だと思ったことが、後で、違うパターンが出てきたことが、逆に、私は目算を誤ったようです。

hige_082さんに、失礼を省みず、こちらは急ぎますので書かせていただきますが、エラー自体は分かりましたが、その原因が、その前のコードの部分には、その理屈で良く分からない部分があります。

こちらで試しますと、

　Next
　a1 = Left(a, InStr(1, a, "（", 1) - 2)
　a = Split(Right(a, Len(a) - InStr(1, a, "）", 1)), "▲")
の　a　が、Empty になっているようです。

たぶん、大本のデータで、Chr(10)のある・なしで、私のほうは、ないという前提で作られています。これは、ご質問者のeizosoftさんに確認していただいたほうがよいですね。

お礼

上手くいきました
ありがとうございます。
長時間お付き合いさせてすいませんでした。

ですが、本当に助かりました。
Wendy02さんのような方がいらっしゃって本当に感謝しております。
本当にありがとうございました。

回答No.10

hige_082

質問の元データ、＃２のお礼の不具合と思われる個所
＃８のお礼のサンプルデータ、すべてクリアしましたけど

Sub test()
Dim a, a1, a2 As Variant
Dim i, ii, iii As Integer
Dim in_sh, out_sh As Worksheet
Set in_sh = Worksheets("sheet1")
Set out_sh = Worksheets("sheet2")
For iii = 1 To in_sh.Range("a" & Rows.Count).End(xlUp).Row
a1 = Split(in_sh.Range("a" & iii).Value, Chr(10))
If in_sh.Range("a" & iii).Value <> "" Then
For i = 1 To UBound(a1)
If a1(i) <> "" Then
If a = "" Then
a = Trim(a1(i))
Else
a = a & "▲" & Trim(a1(i))
End If
Else
End If
Next
a1 = Left(a, InStr(1, a, "（", 1) - 2)
a = Split(Right(a, Len(a) - InStr(1, a, "）", 1)), "▲")
For i = 0 To UBound(a)
If a(i) Like "*）*" Then
a2 = a1 & "▲"
a2 = a2 & Left(a(i), InStr(1, a(i), "）", 1)) & "▲"
a2 = a2 & Right(a(i), Len(a(i)) - InStr(1, a(i), "）", 1))
Else
a2 = a1 & "▲"
a2 = a2 & Left(a(i), InStr(1, a(i), "、", 1) - 1) & "▲"
a2 = a2 & Right(a(i), Len(a(i)) - InStr(1, a(i), "、", 1))
End If
a2 = Split(a2, "▲")
For ii = 0 To UBound(a2)
If ii = 0 Then
out_sh.Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Value = a2(ii)
Else
out_sh.Range("a" & Rows.Count).End(xlUp).Offset(0, ii).Value = a2(ii)
End If
Next ii
Next i
End If
a = ""
Next iii
End Sub

お礼

何度もありがとうございます。
最新のコードですが、「実行時エラー5プロシーシャの呼び出し、または引数が不正です」
と表示されてしまいます。

いま19:51に頂いたものを試しています。
こちらは、役職、名前はパーフェクトです。ただ会議名のところが途中からずっとブランクになるようです。
恐らくここが上手くいけば大丈夫かと思います。この部分について19:51側に記入しましたので、何度もすみませんが確認いただけないでしょうか。

回答No.9

Wendy02

こんばんは。

試してみましたが、どうやら、切り分けの仕方が、二種類あるようなので、切り分けの仕方を二つに分けてみました。大量になると、目では追えませんが、抜けのチェックをしてみました。サンプルでは、抜けは出ていませんが、以下のコードの、Stop のコメントブロックを外すとできます。なお、VBAでは、全角と半角の区分けがややこしいので、一旦、半角にできるものは半角にして、出力の際に全角にしました。原本と食い違いが若干出てきます。

たぶん、必要はないとは思いますが、あまり何度も繰り返して使うようでしたら、
ツール－参照設定で、Microsoft VBScript Regular Express 5.5 にチェックを入れて、
前：Dim Re As Object
↓
Dim Re As VBScript_RegExp_55

前：Set Re = CreateObject("VBScript.RegExp")
　　↓
Set Re = New VBScript_RegExp_55

としてください。（こちらは、XP + IE7 ですから、若干、その表示が変わることがあります。）

'-----------------------------------------------------

Dim Re As Object
Dim j As Long
'出力先
Const oSH As String = "Sheet2"　'シート名
Const COL As Integer = 1　　　　'出力列
'これを実行
Sub LinePickUp1()
　　Dim rng As Variant
　　Dim ret As Variant
　　Dim n As String
　　Dim c As Variant
　　Dim k As Long
　　Set Re = CreateObject("VBScript.RegExp")
　　If WorksheetFunction.CountA(ActiveSheet.Cells) < 2 Then
　　　MsgBox "シートには何もありません。", vbInformation
　　　Exit Sub
　　End If
　　Set rng = Range("A1", Range("A65536").End(xlUp))
　　j = 1
　　For Each c In rng
　　　　If Len(c.Value) > 0 And InStr(1, c.Value, "（会議概要）", vbTextCompare) > 1 Then
　　　　　　n = Mid(Trim(c.Value), 1, InStr(1, c.Value, "（", vbTextCompare) - 1)
　　　　　　k = k + 1
　　　　ElseIf Len(Trim(c.Value)) > 0 And k > 3 Then
　　　　　　n = ""
　　　　End If
　　　　If Len(c.Value) > 0 And InStr(Trim(c.Value), "▲") > 0 Then
　　　　　　ret = Pickup(c.Value)
　　　　　　Listup n, ret
　　　　ElseIf Len(c.Value) > Len(n) And InStr(c.Value, n) = 0 Then
　　　　　　ret = Pickup(c.Value)
　　　　　　Listup n, ret
　　　　End If
　　Next c
　　Set Re = Nothing
　　Application.Goto Worksheets(oSH).Range("A1")
　　MsgBox "出力されました。", vbInformation
End Sub
Private Function Pickup(strLine As Variant)
Dim Matches As Object
Dim Match As Object
Dim Ar() As String
Dim j As Integer
Dim ArStr As Variant
Dim v As Variant
Dim a As Variant
　strLine = Trim(strLine)
　strLine = StrConv(strLine, vbNarrow) '一旦半角
　strLine = Replace(strLine, "(", "（", , , vbBinaryCompare)
　strLine = Replace(strLine, ")", "）", , , vbBinaryCompare)
　If InStr(1, strLine, "（", vbTextCompare) = 1 Then
　 strLine = Mid(strLine, InStr(1, strLine, "）", vbTextCompare) + 1)
　End If
　ArStr = Split(strLine, "▲")
With Re

　.Pattern = "([^（]+)[\s（]*(（[^）]+）)*([A-龠]+)$"
　.Global = True
　For Each v In ArStr
　If InStr(1, v, "、", vbTextCompare) Then
　　 a = Split(v, Chr(164))　'「、」半角
　　 ReDim Preserve Ar(j + 2)
　　　　 a(0) = StrConv(a(0), vbWide) '全角に戻す
　　　　Ar(j) = a(0)
　　　　Ar(j + 1) = ""
　　　　　a(1) = StrConv(a(1), vbWide) '全角に戻す
　　　　Ar(j + 2) = a(1)
　　　　j = j + 3
　ElseIf .test(v) Then
　 Set Matches = .Execute(v)
　 For Each Match In Matches
　　　 On Error Resume Next
　　　 With Match
　　　 ReDim Preserve Ar(j + 2)
　　　　Ar(j) = StrConv(.Submatches(0), vbWide) '全角に戻す
　　　　Ar(j + 1) = StrConv(.Submatches(1), vbWide)
　　　　Ar(j + 2) = StrConv(.Submatches(2), vbWide)
　　　 End With
　　　 On Error GoTo 0
　　　 j = j + 3
　 Next
　End If
　Next v
End With
Pickup = Ar()
End Function
Private Sub Listup(n As String, ret As Variant)
Dim dum As Variant
'出力
　　Dim i As Integer
　　With Worksheets(oSH)
　　On Error Resume Next
　　dum = Empty
　　dum = UBound(ret)
　　On Error GoTo 0
　　If Not IsEmpty(dum) Then
　　　　For i = 0 To UBound(ret) Step 3
　　　　　　On Error Resume Next
　　　　　　.Cells(j, COL).Value = n
　　　　　　.Cells(j, COL + 1).Value = ret(i) & ret(i + 1)
　　　　　　.Cells(j, COL + 2).Value = ret(i + 2)
　　　　　　On Error GoTo 0
　　　　　　j = j + 1
　　　　Next i
　　Else
　　　'Stop '抜けのチェック用
　　End If
　　End With
End Sub

お礼

ブランクになってしまう部分を抜き出しました。
本当は、最初から全部出せればよいのですが、文字数に制限がありすいません。※（）は予め全て半角に直しました。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
ＡＢＣ化学工業(会議概要)2007/03/24""会議室　B""

　ＡＢＣ化学工業
　(３月２４日)管理、取締役及び田中太郎▲電子材料事業部副事業部長兼ディスプレイ材料(半導体材料)田中太郎▲化学品事業本部無機材料事業部材料１、田中太郎▲同材料２、田中太郎

カマナック(会議概要)2007/03/24""会議室　B""

　カマナック
　(３月２４日)総務兼福山工場長、取締役管理本部長の代行として田中太郎

レンタ会議(会議概要)2007/03/24""会議室　B""

　レンタ会議
　(３月２４日)ＹＢＦＣ取締役、社長管理本部長代役田中太郎▲Ｂ―ｎｅｔレンタリース京都取締役兼Ｙｓアセットマネジメント取締役(管理副本部長兼総務)田中太郎

ＤＫ(会議概要)2007/03/24""応接""

　ＤＫ
　(３月２４日)テクノロジーグループ材料・プロセス技術開発センター長、常務執行役員テクノロジーグループＧＭ代役田中太郎▲マグネティクスＢグループＧＭ(回路デバイスＢグループデピュティＧＭ兼回路デバイスＢグループインダクタグループ統括部長)田中太郎▲電子部品営業グループ第二営業統括部長、田中太郎▲ヘッドＢグループＧＭ(ヘッドＢグループデピュティＧＭ)田中太郎
　(３月２４日)アドミニストレーショングループ総務、田中太郎

スクリーン製造(会議概要)2007/03/24""応接""

　スクリーン製造
　(３月２４日)コーポレートコンプライアンス担当、田中太郎・日本太郎

総合開発(会議概要)2007/03/24""応接""

　総合開発
　(３月２４日)取締役(常務企画)田中太郎▲企画、日本太郎・田中太郎

エス会(会議概要)2007/03/24""応接""

　エス会
　(３月２４日、午後スタート)開発部門長(購買部門長)代表取締役兼副社長及び田中太郎▲事業統括副部門長、田中太郎▲エスエンジニアリングＵＳＡ(開発部門長)田中太郎▲購買部門長(海外事業統括副部門長兼購買副部門長)田中太郎
　第二営業、根本淳▲第四営業(営業総括部長)田中太郎▲購買企画、第二購買・田中太郎▲開発総括部長(商品企画)田中太郎

回答No.8

Wendy02

こんにちは。

▲が入らないものも拾えるようにしました。
最初の質問の
>４．会議毎に２行ずつ行を空けています
これを、利用してみました。

'--------------------------------------
Dim Re As Object
Dim j As Long
'出力先
Const oSH As String = "Sheet2"　'シート名
Const COL As Integer = 1　　　　'出力列
'これを実行
Sub LinePickUp1()
　　Dim rng As Variant
　　Dim ret As Variant
　　Dim n As String
　　Dim c As Variant
　　Set Re = CreateObject("VBScript.RegExp")
　　Set rng = Range("A1", Range("A65536").End(xlUp))
　　j = 1
　　For Each c In rng
　　　　If Len(c.Value) > 0 And InStr(1, c.Value, "（会議概要）", vbTextCompare) > 1 Then
　　　　　　n = Mid(Trim(c.Value), 1, InStr(1, c.Value, "（", vbTextCompare) - 1)
　　　　　　k = k + 1
　　　　ElseIf Len(Trim(c.Value)) > 0 And k > 3 Then
　　　　　　n = ""
　　　　End If
　　　　If Len(c.Value) > 0 And InStr(Trim(c.Value), "▲") > 0 Then
　　　　　　ret = Pickup(c.Value)
　　　　　　Listup n, ret
　　　　ElseIf Len(c.Value) > Len(n) And InStr(c.Value, n) = 0 Then
　　　　　　ret = Pickup(c.Value)
　　　　　　Listup n, ret
　　　　End If
　　Next c
　　Set Re = Nothing
　　Application.Goto Worksheets(oSH).Range("A1")
　　MsgBox "出力されました。", vbInformation
End Sub

'以下は同じです。
Private Function Pickup(strLine As Variant)
Dim Matches As Object
Dim Match As Object
Dim Ar() As String
　・
　・
　・

わたくし事ですが、なんとか、今日中に作れないと、次のアクセスは予定が取れません。

お礼

お忙しいところありがとうございます。
頂いたもので、色々な会議名のものを拾うことが出来ました。
かなり近いところまで来ているのですが、本番データで動かすと、文章の区切りが合わない所が出てきました。
文章の区切りが合わなかった部分のサンプルデータを下記に乗せます。
（後出しになってすいません。文章量が多く、最初のものはかなり削ったものでした）

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
都市ガイサン会議（会議概要）2007/03/27""会議室　Ｄ""

　都市ガイサン会議
　（３月２７日午前１０時）営業担当（営業副部長）田中太郎本部長出張中のため▲品質保証担当（技術開発本部長）田中太郎▲財務部・情報管理部・総務部・人事部担当（管理本部長）田中太郎▲都市ガイサン事業部都市機器生産兼事業企画部生産企画室長（生産本部副本部長）田中太郎▲都市ガイサン事業部長（同本部都市ガイサン機器営業）田中太郎▲同部製品開発室長（技術開発本部東京研究室長兼開発企画室長）田中太郎▲同保守・施工管理室長（営業本部サービスセンター所長）田中太郎▲品質保証（品質管理）田中太郎▲エレクトロニクス事業部、田中太郎・日本太郎▲同事業部水機器生産、田中太郎
　〔営業本部〕情報機器営業統括部東日本Ｇ（国内情報機器営業本部営業第２）田中太郎▲計測・ＦＡ営業統括部計測営業（国内計測・ＦＡ営業本部計測・ＦＡ営業）田中太郎
　データ整備技術統括部長（関連技術）田中太郎▲カッティング技術統括部カッティング１＆２（カッティング技術）田中太郎

ＡＢＣキャピタル（会議概要）2007/03/29""小会議室""

　ＡＢＣキャピタル
　（来社）CEO、ヴィンツェンツォ・シーフォ・スターレンス▲CFO、アンドレアス・イジンシュイッツ

レンタ会議（会議概要）2007/03/29""Ｃ会議室""

　レンタ会議
　（３月２９日午前１０時）ＹＪ―NETレンタリース取締役兼Ｙｓアセットマネジメント取締役（コンテンツ事業部長兼デジタル・プロダクツ事業部長）田中太郎

回答No.7

hige_082

ちょっと修正しましたけど
動きますかね

Sub test()
Dim a, a1, a2 As Variant
Dim i, ii, iii As Integer
For iii = 1 To Worksheets("sheet1").Range("a65536").End(xlUp).Row
a1 = Split(Worksheets("sheet1").Range("a" & iii).Value, Chr(10))
If Worksheets("sheet1").Range("a" & iii).Value = "" Then GoTo mmm
a = ""
For i = 1 To UBound(a1)
If a1(i) <> "" Then
If a = "" Then
a = Trim(a1(i))
Else
a = a & "▲" & Trim(a1(i))
End If
Else
End If
Next
a1 = Split(a, "▲")
a = Right(a, Len(a) - InStr(1, a, "）", 1))
a = Split(a, "▲")
For i = 0 To UBound(a)
If a(i) Like "*）*" Then
a2 = a1(0) & " "
a2 = a2 & Left(a(i), InStr(1, a(i), "）", 1)) & " "
a2 = a2 & Right(a(i), Len(a(i)) - InStr(1, a(i), "）", 1))
Else
a2 = a1(0) & " "
a2 = a2 & Left(a(i), InStr(1, a(i), "、", 1) - 1) & " "
a2 = a2 & Right(a(i), Len(a(i)) - InStr(1, a(i), "、", 1))
End If
a2 = Split(a2)
For ii = 0 To UBound(a2)
If ii = 0 Then
Worksheets("sheet2").Range("a65536").End(xlUp).Offset(1, 0).Value = a2(ii)
Else
Worksheets("sheet2").Range("a65536").End(xlUp).Offset(0, ii).Value = a2(ii)
End If
Next ii
Next i
mmm:
Next iii
End Sub

回答No.6

Wendy02

こんばんは。

>３．1行目の会議名から3行下に再度会議名、その下に参加者が入る
>４．1行目の会議名の後に、必ず（会議概要）と入っている。（）は全角。

3. 4.私には、一番、確実な気がします。
ここはできましたが、今度は、次の行があやふやになりました。

[ここで、会議室名称を取得]
>臨時営業戦略会議（会議概要）2007/03/24""会議室　A"" 　
>
>
>　臨時営業戦略会議 [ここは無視]
[ここから拾っていくのてすが、上記と下記の違いでは、▲マークなどが必要です。]
>　（３月２４日午後２時）営業本部長（国内営業）日本太郎▲営業管理、日本太郎
>　関東・北陸営業本部長、日本太郎▲総合企画（営業本部販売推進）日本太郎

プログラムの話ですから、話が見えてこないかもしれませんが、確保している会議名と一緒なら、その次から、拾うという考え方もできるのですが、その次の行も続くので、会議名から3行目が、あやふやになってしまいます。

できないことはないのですが、実は、▲マークなしでも取れるように作ったために、対象外の行でも、誤って取れてしまいます。

氏名が入っている行を確実に拾うためには、やはり「▲」マークが必要になりました。前言と矛盾してしまいますが、それは大丈夫ですか？（つまり、氏名を取る行には、「▲」マークが入っていないといけない、ということです。）

お礼

遅くまでありがとうございます。

▲は、ほぼ入っていますが、100%ではありません。
1名しか記入がない場合があり、その場合は▲は使われていません。
ただ、条件として▲が必須であれば、▲が付いているところだけでも処理が出来ればと思います。

▲無しの部分は、後から手作業で対応します。
もし可能であれば、▲無しの部分だけまとめてピックアップできると助かりますが、、、

無理を言ってすみません。
よろしくお願いします。

回答No.5

Wendy02

こんばんは。

>会議名に規則性がなく、「打ち合わせ」や来客の社名「○○社」だけと入っている場合があります。

なんとか、条件がないところを逆に規則性にしないと難しいですね。いわゆる排他的条件というものかもしれません。

例えば、
（　）や▲などの記号が入らない。
If Len(c.Value) > 0 And Not Trim(c.Value) Like "*[▲|（|）]*" Then

　月例営業戦略会議　など、文字数が、20字以下。
If Len(c.Value) > 0 And Len(Trim(c.Value)) <= 20 Then

次の行と比較すると、半分以下の文字数。
If Len(c.Value) > 0 And Len(Trim(c.Value)) < Len(Trim(c.Offset(1).Value)) / 2 Then

前後は別にして、文字の途中に、全角・半角を問わずスペース2つは入らない。
If Len(c.Value) > 0 And Len(Trim(c.Value)) - Len(Replace(Trim(c.Value), Space(1), "", , , vbTextCompare)) < 2 Then

など。こんな中から見つけ出せないでしょうか？

理屈からすると、データ（役職と氏名）を取得した行の手前の行が、会議名とは言えます。しかし、一旦、そのデータをプールしなければならないのですが、時系列でないと、その会議名を捨てるタイミングに自信がないのです。

#2さんのエラーは、丸括弧の半角・全角の違いだと思います。

お礼

早速のご返答ありがとうございます。
会議名について規則性を探してみました。
１．（　）や▲などの記号が入らない。
２．文字の途中に、全角・半角を問わずスペース2つは入らない。
の２つが当てはまります。

また、以下もありました。
３．1行目の会議名から3行下に再度会議名、その下に参加者が入る
４．1行目の会議名の後に、必ず（会議概要）と入っている。（）は全角。
※2つ目のサンプルデータでは、私の転記ミスで違う名前ですが、1行目と4行目の会議名は本来は同じです。

このような規則性で大丈夫でしょうか？

回答No.4

Wendy02

#3の回答者です。
ご質問者さんの反応をみずに、続けるのは無駄にはなるのは承知ですが、#3のコードを書き換えました。

変更点は、出力先を選択できるのと、▲の数に関係なく、切り分けることを考えました。つまり、ない場合も含めています。

なお、コードの中の
　If Len(c.Value) > 0 And Trim(c.Value) Like "*[例会|会議]" Then
この部分の、会議名の最後の部分が、「例会、会議」以外のものがあれば、ここに書き加えないとピックアップできません。挿入する場合は、「|」を区切り文字にしてください。

2箇所変更部分があります。

例：
Like　"*[例会|会議|部会]" Then

'---------------------------------------------
'標準モジュール
'---------------------------------------------

Dim Re As Object
Dim j As Long
'出力先
Const oSH As String = "Sheet2"　'シート名
Const COL As Integer = 1　　　　'出力列
'これを実行
Sub LinePickUp1()
　　Dim rng As Variant
　　Dim ret As Variant
　　Dim n As String
　　Dim c As Variant
　　Set Re = CreateObject("VBScript.RegExp")
　　Set rng = Range("A1", Range("A65536").End(xlUp))
　　j = 1
　　For Each c In rng
　　　　'例会,会議　など、会議名の後ろに付ける名称を入れる
　　　　If Len(c.Value) > 0 And Trim(c.Value) Like "*[例会|会議]" Then
　　　　　　n = Trim(c.Value)
　　　　ElseIf Len(Trim(c.Value)) = 0 Then
　　　　　　n = ""
　　　　End If
　　　　If Len(c.Value) > 0 And (Not c.Value Like "*[例会|会議]*") Then
　　　　　　ret = Pickup(c.Value)
　　　　　　Listup n, ret
　　　　End If
　　Next c
　　Set Re = Nothing
　　Application.Goto Worksheets(oSH).Range("A1")
　　MsgBox "出力されました。", vbInformation
End Sub
Private Function Pickup(strLine As Variant)
Dim Matches As Object
Dim Match As Object
Dim Ar() As String
Dim j As Integer
　strLine = Trim(strLine)
　strLine = Replace(strLine, "(", "（", , , vbBinaryCompare)
　strLine = Replace(strLine, ")", "）", , , vbBinaryCompare)
　If InStr(1, strLine, "（", vbTextCompare) = 1 Then
　 strLine = Mid(strLine, InStr(1, strLine, "）", vbTextCompare) + 1)
　End If

With Re
　.Pattern = "[\s▲]*([・一-龠]+)[、\s]*(（[^）]+）)*([ぁ-龠]+)"
　.Global = True
　If .test(strLine) Then
　 Set Matches = .Execute(strLine)
　 For Each Match In Matches
　　　 On Error Resume Next
　　　 With Match
　　　 ReDim Preserve Ar(j + 2)
　　　　Ar(j) = .Submatches(0)
　　　　Ar(j + 1) = .Submatches(1)
　　　　Ar(j + 2) = .Submatches(2)
　　　 End With
　　　 On Error GoTo 0
　　　 j = j + 3
　 Next
　End If
End With
Pickup = Ar()
End Function
Private Sub Listup(n As String, ret As Variant)
'出力
　　Dim i As Integer
　　With Worksheets(oSH)
　　If IsArray(ret) Then
　　　　For i = 0 To UBound(ret) Step 3
　　　　　　On Error Resume Next
　　　　　　.Cells(j, COL).Value = n
　　　　　　.Cells(j, COL + 1).Value = ret(i) & ret(i + 1)
　　　　　　.Cells(j, COL + 2).Value = ret(i + 2)
　　　　　　On Error GoTo 0
　　　　　　j = j + 1
　　　　Next i
　　End If
　　End With
End Sub

お礼

ご回答ありがとうございます。
頂いたコードでサンプルデータは上手く動作しました。
ただ、会議名に規則性がなく、「打ち合わせ」や来客の社名「○○社」だけと入っている場合があります。
この様な場合でも、対応する方法はないでしょうか？

回答No.3

Wendy02

こんばんは。

仕事を請けてしまったようですが、VBA等で、うまくいくのか、なんとも言えません。少なくとも、ご質問者さんが無理だと感じているなら、その仕事を請けてしまったとしたら、まずかったように思います。手作業ということもありますが。

プログラムを作るにしても、まず、そこから、規則性を見出さなくてはならないと思います。実際は、Excel向きではなく、Excelで代用するという感じです。VBA/VB系は、残念ながらこの手のものは、そんなに強くありません。

リストに1～5まで書かれていますが、

>４．会議毎に２行ずつ行を空けています。
>５．役職と氏名の区切り方は、"（ ）" もしくは "、"　になっています。
>６．人と人との区切り方は、"▲"になっています

このぐらいでは足りません。もう少し、規則性を詰めないとダメだと思います。
必ずしも、「▲」があるとは言えないと読みました。

サンプルのデータでは、できるとは言えません。いろんなパターンのサンプルが必要です。

ただ、できないといわれて、あまり何度も修正しなおすのは、このようなフリーの掲示板では相応しくありません。現在のサンプルから導きだせるパターン・プログラムです。

現在のコードでは、「▲」は、一つだけの区切りしか使えません。複数の場合は、以下のコードを少し変更すれば可能です。

これを、修正するには、正規表現の知識が必要になります。

'----------------------------------------------
Dim Re As Object
Dim j As Long
Sub LinePickUp1()
Dim rng As Variant
Dim ret As Variant
Dim n As String
Dim c As Variant
Set Re = CreateObject("VBScript.RegExp")
Set rng = Range("A1", Range("A65536").End(xlUp))
j = 1
For Each c In rng
'例会,会議　など、会議名の後ろに付ける名称を入れる
If Len(c.Value) > 0 And Trim(c.Value) Like "*[例会|会議]" Then
　　　n = Trim(c.Value)
　ElseIf Len(Trim(c.Value)) = 0 Then
　　　n = ""
　End If
　If Len(c.Value) > 0 And (Not c.Value Like "*[例会|会議]*") Then
　　ret = Pickup(c.Value)
　　Listup n, ret
　End If
Next c
Set Re = Nothing
End Sub
Function Pickup(strLine As Variant)
Dim Matches As Object
Dim Match As Object
Dim Ar(5) As String
Dim j As Integer
'括弧を全角にする
　strLine = Trim(strLine)
　strLine = Replace(strLine, "(", "（", , , vbBinaryCompare)
　strLine = Replace(strLine, ")", "）", , , vbBinaryCompare)
　If InStr(1, strLine, "（", vbTextCompare) = 1 Then
　 strLine = Mid(strLine, InStr(1, strLine, "）", vbTextCompare) + 1)
　End If

With Re
　.Pattern = "[\s▲]*([・一-龠]+)[、\s]*(（[^）]+）)*([ぁ-龠]+)"
　.Global = True
　If .test(strLine) Then
　 Set Matches = .Execute(strLine)
　 For Each Match In Matches
　　　 On Error Resume Next
　　　 With Match
　　　　Ar(j) = .Submatches(0)
　　　　Ar(j + 1) = .Submatches(1)
　　　　Ar(j + 2) = .Submatches(2)
　　　 End With
　　　 On Error GoTo 0
　　　 j = 3
　 Next
　End If
End With
Pickup = Ar()
End Function
Sub Listup(n As String, ret As Variant)
Const COL As Integer = 3
If IsArray(ret) Then
　On Error Resume Next
　Cells(j, COL).Value = n
　Cells(j, COL + 1).Value = ret(0) & ret(1)
　Cells(j, COL + 2).Value = ret(2)

　Cells(j + 1, COL).Value = n
　Cells(j + 1, COL + 1).Value = ret(3) & ret(4)
　Cells(j + 1, COL + 2).Value = ret(5)
　On Error GoTo 0
End If
j = j + 2
End Sub

回答No.2

hige_082

自分ではあまりやらない処理なので
面白そうなので、作ってみました
試しに作り始めて３時間もかかってしまいました
やっつけで作ったので見苦しいコードですが
突っ込みは禁止です

Sub test()
Dim a, a1, a2 As Variant
Dim i, ii, iii As Integer
For iii = 1 To Worksheets("sheet1").Range("a65536").End(xlUp).Row
a1 = Split(Range("a" & iii).Value, Chr(10))
If Range("a" & iii).Value = "" Then GoTo mmm
a = ""
For i = 1 To UBound(a1)
If a1(i) <> "" Then
If a = "" Then
a = Trim(a1(i))
Else
a = a & "▲" & Trim(a1(i))
End If
Else
End If
Next
a1 = Split(a, "▲")
a = Right(a, Len(a) - WorksheetFunction.Find("）", a, 1))
a = Split(a, "▲")
For i = 0 To UBound(a)
If a(i) Like "*）*" Then
a2 = a1(0) & " "
a2 = a2 & Left(a(i), WorksheetFunction.Find("）", a(i), 1)) & " "
a2 = a2 & Right(a(i), Len(a(i)) - WorksheetFunction.Find("）", a(i), 1))
Else
a2 = a1(0) & " "
a2 = a2 & Left(a(i), WorksheetFunction.Find("、", a(i), 1) - 1) & " "
a2 = a2 & Right(a(i), Len(a(i)) - WorksheetFunction.Find("、", a(i), 1))
End If
a2 = Split(a2)
For ii = 0 To UBound(a2)
If ii = 0 Then
Worksheets("sheet2").Range("a65536").End(xlUp).Offset(1, 0).Value = a2(ii)
Else
Worksheets("sheet2").Range("a65536").End(xlUp).Offset(0, ii).Value = a2(ii)
End If
Next ii
Next i
mmm:
Next iii
End Sub

人前に出すのも恥ずかしいコードですが
自分の戒めで乗せました
gotoはありえないと自分でも思います
もっと勉強しなくちゃ

一応自分の環境では動きましたが
詳細が不明な所は想像ですので
質問者さんの環境では動かない可能性大です
お粗末でした

お礼

ご回答ありがとうございます。
実行すると、「実行時エラー'1004':アプリケーション定義またはオブジェクト定義のエラーです。」と表記されストップしてしまいます。
私の環境が駄目なのでしょうか？
今、Excel2000を使っています（会社ではExcel2003です）。
どうすると動作するでしょうか？

回答No.1

xls88

Split関数が使えると下記のようなことができます。
Excel2000以降使える関数だったと思います。

Sub test名前抽出()
　　Dim str As String
　　str = "（３月２４日午前１０時）品質保証担当（開発本部長）日本太郎▲事業企画、日本太郎"
　　MsgBox Split(Split(str, "▲")(0), "）")(2)
End Sub

お礼

回答ありがとうございます。