- ベストアンサー
エクセルのマクロを使って、データをまとめる方法を教えてください
最近関数を使い始めたエクセル初心者です。 会社でまとめてくれと、数年分の会議出席者のエクセルファイルを渡されたのですが、うまくマクロが作れず困っています。 マクロが分かる方、教えて頂けないでしょうか。 どうかよろしくお願いいたします。 1.データの内容は、大きく分けると「会議名」 「出席者の役職or所属」 「氏名」で構成されています。 2.データは、エクセルの1列(A列)だけを使って縦に延々と入力されています。 3.一つの文章は、基本的に1つのセルに入っています。 (横に長い文章はたまに下のセルに入力されています) 4.会議毎に2行ずつ行を空けています。 5.役職と氏名の区切り方は、"( )" もしくは "、" になっています。 6.人と人との区切り方は、"▲"になっています 【元のデータ】 | ←A列→ | ************************************************************* 品質改善定例会(会議概要)2007/03/24""会議室 B"" 品質改善定例会 (3月24日午前10時)品質保証担当(開発本部長)日本太郎▲事業企画、日本太郎 臨時営業戦略会議(会議概要)2007/03/24""会議室 A"" 月例営業戦略会議 (3月24日午後2時)営業本部長(国内営業)日本太郎▲営業管理、日本太郎 関東・北陸営業本部長、日本太郎▲総合企画(営業本部販売推進)日本太郎 ************************************************************ ↓ 【このようにまとめたいです】 | ←A列→ | ←B列→ | ←C列→ | 会議名 役職名 氏名 *********************************************************** 品質改善定例会 品質保証担当(開発本部長) 日本太郎 品質改善定例会 事業企画 日本太郎 月例営業戦略会議 営業本部長(国内営業) 日本太郎 月例営業戦略会議 営業管理(営業副本部長) 日本太郎 月例営業戦略会議 関東・北陸営業本部長 日本太郎 月例営業戦略会議 総合企画(営業本部販売推進)日本太郎 ************************************************************
- eizosoft
- お礼率61% (11/18)
- オフィス系ソフト
- 回答数11
- ありがとう数11
- みんなの回答 (11)
- 専門家の回答
質問者が選んだベストアンサー
こんばんは。 >本当は、最初から全部出せればよいのですが、文字数に制限がありすいません。※()は予め全て半角に直しました。 どちらでも構いませんが、初期設定では、丸括弧は、「全角」という前提になっています。「半角」にしても、プログラム上で、全角に戻ってしまいます。 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さんに確認していただいたほうがよいですね。
その他の回答 (10)
- hige_082
- ベストアンサー率50% (379/747)
質問の元データ、#2のお礼の不具合と思われる個所 #8のお礼のサンプルデータ、すべてクリアしましたけど 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側に記入しましたので、何度もすみませんが確認いただけないでしょうか。
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 試してみましたが、どうやら、切り分けの仕方が、二種類あるようなので、切り分けの仕方を二つに分けてみました。大量になると、目では追えませんが、抜けのチェックをしてみました。サンプルでは、抜けは出ていませんが、以下のコードの、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
お礼
ブランクになってしまう部分を抜き出しました。 本当は、最初から全部出せればよいのですが、文字数に制限がありすいません。※()は予め全て半角に直しました。 ******************* ABC化学工業(会議概要)2007/03/24""会議室 B"" ABC化学工業 (3月24日)管理、取締役及び田中太郎▲電子材料事業部副事業部長兼ディスプレイ材料(半導体材料)田中太郎▲化学品事業本部無機材料事業部材料1、田中太郎▲同材料2、田中太郎 カマナック(会議概要)2007/03/24""会議室 B"" カマナック (3月24日)総務兼福山工場長、取締役管理本部長の代行として田中太郎 レンタ会議(会議概要)2007/03/24""会議室 B"" レンタ会議 (3月24日)YBFC取締役、社長管理本部長代役田中太郎▲B―netレンタリース京都取締役兼Ysアセットマネジメント取締役(管理副本部長兼総務)田中太郎 DK(会議概要)2007/03/24""応接"" DK (3月24日)テクノロジーグループ材料・プロセス技術開発センター長、常務執行役員テクノロジーグループGM代役田中太郎▲マグネティクスBグループGM(回路デバイスBグループデピュティGM兼回路デバイスBグループインダクタグループ統括部長)田中太郎▲電子部品営業グループ第二営業統括部長、田中太郎▲ヘッドBグループGM(ヘッドBグループデピュティGM)田中太郎 (3月24日)アドミニストレーショングループ総務、田中太郎 スクリーン製造(会議概要)2007/03/24""応接"" スクリーン製造 (3月24日)コーポレートコンプライアンス担当、田中太郎・日本太郎 総合開発(会議概要)2007/03/24""応接"" 総合開発 (3月24日)取締役(常務企画)田中太郎▲企画、日本太郎・田中太郎 エス会(会議概要)2007/03/24""応接"" エス会 (3月24日、午後スタート)開発部門長(購買部門長)代表取締役兼副社長及び田中太郎▲事業統括副部門長、田中太郎▲エスエンジニアリングUSA(開発部門長)田中太郎▲購買部門長(海外事業統括副部門長兼購買副部門長)田中太郎 第二営業、根本淳▲第四営業(営業総括部長)田中太郎▲購買企画、第二購買・田中太郎▲開発総括部長(商品企画)田中太郎
- Wendy02
- ベストアンサー率57% (3570/6232)
こんにちは。 ▲が入らないものも拾えるようにしました。 最初の質問の >4.会議毎に2行ずつ行を空けています これを、利用してみました。 '-------------------------------------- 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""会議室 D"" 都市ガイサン会議 (3月27日午前10時)営業担当(営業副部長)田中太郎本部長出張中のため▲品質保証担当(技術開発本部長)田中太郎▲財務部・情報管理部・総務部・人事部担当(管理本部長)田中太郎▲都市ガイサン事業部都市機器生産兼事業企画部生産企画室長(生産本部副本部長)田中太郎▲都市ガイサン事業部長(同本部都市ガイサン機器営業)田中太郎▲同部製品開発室長(技術開発本部東京研究室長兼開発企画室長)田中太郎▲同保守・施工管理室長(営業本部サービスセンター所長)田中太郎▲品質保証(品質管理)田中太郎▲エレクトロニクス事業部、田中太郎・日本太郎▲同事業部水機器生産、田中太郎 〔営業本部〕情報機器営業統括部東日本G(国内情報機器営業本部営業第2)田中太郎▲計測・FA営業統括部計測営業(国内計測・FA営業本部計測・FA営業)田中太郎 データ整備技術統括部長(関連技術)田中太郎▲カッティング技術統括部カッティング1&2(カッティング技術)田中太郎 ABCキャピタル(会議概要)2007/03/29""小会議室"" ABCキャピタル (来社)CEO、ヴィンツェンツォ・シーフォ・スターレンス▲CFO、アンドレアス・イジンシュイッツ レンタ会議(会議概要)2007/03/29""C会議室"" レンタ会議 (3月29日午前10時)YJ―NETレンタリース取締役兼Ysアセットマネジメント取締役(コンテンツ事業部長兼デジタル・プロダクツ事業部長)田中太郎
- hige_082
- ベストアンサー率50% (379/747)
ちょっと修正しましたけど 動きますかね 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
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 >3.1行目の会議名から3行下に再度会議名、その下に参加者が入る >4.1行目の会議名の後に、必ず(会議概要)と入っている。()は全角。 3. 4.私には、一番、確実な気がします。 ここはできましたが、今度は、次の行があやふやになりました。 [ここで、会議室名称を取得] >臨時営業戦略会議(会議概要)2007/03/24""会議室 A"" > > > 臨時営業戦略会議 [ここは無視] [ここから拾っていくのてすが、上記と下記の違いでは、▲マークなどが必要です。] > (3月24日午後2時)営業本部長(国内営業)日本太郎▲営業管理、日本太郎 > 関東・北陸営業本部長、日本太郎▲総合企画(営業本部販売推進)日本太郎 プログラムの話ですから、話が見えてこないかもしれませんが、確保している会議名と一緒なら、その次から、拾うという考え方もできるのですが、その次の行も続くので、会議名から3行目が、あやふやになってしまいます。 できないことはないのですが、実は、▲マークなしでも取れるように作ったために、対象外の行でも、誤って取れてしまいます。 氏名が入っている行を確実に拾うためには、やはり「▲」マークが必要になりました。前言と矛盾してしまいますが、それは大丈夫ですか?(つまり、氏名を取る行には、「▲」マークが入っていないといけない、ということです。)
お礼
遅くまでありがとうございます。 ▲は、ほぼ入っていますが、100%ではありません。 1名しか記入がない場合があり、その場合は▲は使われていません。 ただ、条件として▲が必須であれば、▲が付いているところだけでも処理が出来ればと思います。 ▲無しの部分は、後から手作業で対応します。 もし可能であれば、▲無しの部分だけまとめてピックアップできると助かりますが、、、 無理を言ってすみません。 よろしくお願いします。
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 >会議名に規則性がなく、「打ち合わせ」や来客の社名「○○社」だけと入っている場合があります。 なんとか、条件がないところを逆に規則性にしないと難しいですね。いわゆる排他的条件というものかもしれません。 例えば、 ( )や▲などの記号が入らない。 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さんのエラーは、丸括弧の半角・全角の違いだと思います。
お礼
早速のご返答ありがとうございます。 会議名について規則性を探してみました。 1.( )や▲などの記号が入らない。 2.文字の途中に、全角・半角を問わずスペース2つは入らない。 の2つが当てはまります。 また、以下もありました。 3.1行目の会議名から3行下に再度会議名、その下に参加者が入る 4.1行目の会議名の後に、必ず(会議概要)と入っている。()は全角。 ※2つ目のサンプルデータでは、私の転記ミスで違う名前ですが、1行目と4行目の会議名は本来は同じです。 このような規則性で大丈夫でしょうか?
- Wendy02
- ベストアンサー率57% (3570/6232)
#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
お礼
ご回答ありがとうございます。 頂いたコードでサンプルデータは上手く動作しました。 ただ、会議名に規則性がなく、「打ち合わせ」や来客の社名「○○社」だけと入っている場合があります。 この様な場合でも、対応する方法はないでしょうか?
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 仕事を請けてしまったようですが、VBA等で、うまくいくのか、なんとも言えません。少なくとも、ご質問者さんが無理だと感じているなら、その仕事を請けてしまったとしたら、まずかったように思います。手作業ということもありますが。 プログラムを作るにしても、まず、そこから、規則性を見出さなくてはならないと思います。実際は、Excel向きではなく、Excelで代用するという感じです。VBA/VB系は、残念ながらこの手のものは、そんなに強くありません。 リストに1~5まで書かれていますが、 >4.会議毎に2行ずつ行を空けています。 >5.役職と氏名の区切り方は、"( )" もしくは "、" になっています。 >6.人と人との区切り方は、"▲"になっています このぐらいでは足りません。もう少し、規則性を詰めないとダメだと思います。 必ずしも、「▲」があるとは言えないと読みました。 サンプルのデータでは、できるとは言えません。いろんなパターンのサンプルが必要です。 ただ、できないといわれて、あまり何度も修正しなおすのは、このようなフリーの掲示板では相応しくありません。現在のサンプルから導きだせるパターン・プログラムです。 現在のコードでは、「▲」は、一つだけの区切りしか使えません。複数の場合は、以下のコードを少し変更すれば可能です。 これを、修正するには、正規表現の知識が必要になります。 '---------------------------------------------- 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
- hige_082
- ベストアンサー率50% (379/747)
自分ではあまりやらない処理なので 面白そうなので、作ってみました 試しに作り始めて3時間もかかってしまいました やっつけで作ったので見苦しいコードですが 突っ込みは禁止です 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です)。 どうすると動作するでしょうか?
- xls88
- ベストアンサー率56% (669/1189)
Split関数が使えると下記のようなことができます。 Excel2000以降使える関数だったと思います。 Sub test名前抽出() Dim str As String str = "(3月24日午前10時)品質保証担当(開発本部長)日本太郎▲事業企画、日本太郎" MsgBox Split(Split(str, "▲")(0), ")")(2) End Sub
お礼
回答ありがとうございます。
関連するQ&A
- エクセルでデータの編集
A列に氏名が列記してあり、氏名の頭に数字(リーディングゼロなし、最大3桁)が付いています。例:下記 A 1山本太郎 2日本次郎 28鈴木花子 336小泉純一 これらの数字を削除してB列を作りたい。例:下記 B 山本太郎 日本次郎 鈴木花子 小泉純一 こつこつでなく、一発で編集できますか?
- ベストアンサー
- オフィス系ソフト
- エクセル:フォントの大きさの調整について
よろしくお願いいたします ◆エクセルのシート「名簿」のF列に『役職』 G列に『氏名』が入っています。 ◆シート「ラベル」に =名簿!F2&" "&名簿!G2&"様" という計算式を入れています。つまりラベル印刷としてこちらを印刷して封筒に貼り付けるようにしたいのです。ここではたとえば「代表取締役 山田太郎様」という表示になります。 ◆(やりたいこと) そこで、上記計算式の名簿!F3&" "&名簿!G3&"様"の名簿!F3(役職)のフォントの大きさを「11」、名簿!G3(氏名)&"様"のフォントの大きさを「14」などという設定は可能でしょうか?可能ならば教えてください。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 会議
会議について 会議の目的は何でしょうか?(戦略とは?) 会議が単なる報告会となっている傾向が強く時間の無駄となっています。 各部署、営業店が出席して開催しておりますが、なぜこのような状態に なるのでしょか?
- 締切済み
- その他(ビジネス・キャリア)
- こんなことエクセル関数でできますか?
お世話になります。 エクセルの1列に日本人の氏名が約2000名分並んでいます。1セル1名なので例えばA1セル~A2000セルに2000名分の氏名が入力されているといった感じです。 氏名は全角漢字で姓と名の間に全角のスペースが入っています。 ここで、この2000名の中で同姓同名(漢字が全て同じ)を即座に知る方法を探しています。 例えば、山田 太郎がA1、A409、A1765にあり、佐藤 花子がA222、A288にある事実を簡単に知る方法を探しています。 エクセルの関数を使って出来ないでしょうか? (関数が入力された1列2000行に2000名の名前を貼り付けると、B1、B409、B1765に山田 太郎が返ってくるとか・・・。) 宜しくお願いいたします。
- ベストアンサー
- Excel(エクセル)
- Word内の表の文字をExcelへ自動でコピー
Word内全ページの表の記載文字をExcelへ自動でコピーするのは可能でしょうか? Word内に表があり、その列ごとを指定し、Excelの指定した列へ自動でコピーする方法はあるでしょうか? Wordは数百ページあり、これを手作業で行うのは時間が掛かりとても面倒です。 【例】 Word 氏名 社員番号 所属 役職 鈴木 100 営業部 主任 伊藤 200 総務部 係長 高橋 300 製造部 一般 ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ Excel 社員番号 氏名 役職 所属 100 鈴木 主任 営業部 200 伊藤 係長 総務部 300 高橋 一般 製造部
- 締切済み
- その他MS Office製品
- VBA で抽出したデータが一定数まできたら、異なるセルに折り返して抽出するように設定したい。
VBA で抽出したデータが一定数まできたら、異なるセルに折り返して抽出するように設定したいです。 ◇シート1◇ ※元データ A B C D 1| 氏名 役職 部署 年齢 ―――――――――――――――― 2| 山田 社員 開発 45 3| 田中 社員 人事 42 4| 鈴木 派遣 企画 30 5| 高橋 役員 人事 50 6| 坂野 社員 企画 33 7| 井上 派遣 企画 29 ◇シート2◇ 条件1.役職は"役員"で、部署が"人事"の人の 氏名、役職、部署をA3から順に抽出する 条件2.A列のデータが9行目まできたら D3に抽出されるようにする A B C D E F 1 氏名 役職 部署 氏名 役職 部署 2 高橋 役員 人事 3 4 5 6 7 8 9 ―――――――――――――――――――― ちなみにこのサイトで以下のコードを作成してもらいましたが これだとデータ元の全ての行が抽出されてしまいます。 Private Sub Worksheet_Activate() With Sheets("Sheet1") .AutoFilterMode = False .Range("A1:E1").AutoFilter .Range("A1:E1").AutoFilter Field:=2, Criteria1:="役員" .Range("A1:E1").AutoFilter Field:=3, Criteria1:="人事" .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy Range("A3") .AutoFilterMode = False End With End Sub 条件2のデータを折り返す条件が難しいようであれば 条件1の3列のみ抽出する方法で結構ですので教えてください。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 品格、統合、企業発展中心
すみません、韓国語の微妙なニュアンスがわかりません。 品格競争。は日本語の品質競争 委員会構成。は委員会を作る 経験価値創出。はcustomer experience 企業発展中心。は企業の(かなりtopの)経営企画会議? と解釈してよいでしょうか。
- ベストアンサー
- 韓国語
- エクセルで、出来そうなのですが、教えてください。
エクセルで、出来そうなのですが、教えてください。 初心者で、初めて質問します。 私の会社のパートさんや、アルバイトさんの勤怠表と給与明細を作ってるのですが、 下のような スタッフ一覧を作りそのデーダーをもとに各個人名のシートの各項目セルに 飛ぶように作ってみましたが、 知りたいのは A列の出勤の上がってる方だけ、1つの操作で、印刷したいのです。 A 列の出勤数は、各個人明細所の出勤数に連動してます。 E 列の名前と個人明細書のSheetにリンクさせてます。 田中太郎さんは、sheet1、田中花子さんは、sheet2に、なっているので、 A列が、0より多い時は、5番目の氏名のリンクを印刷する。 等 VLOOKUPやIFでやれないかと 考えましたが、 答えが出ません、マクロも自動登録しかできないので、困ってます。 スミマセンとても分かりずらいのですが・・・・A列出勤数 B列週払い(チェツクリスト) c列個人シートのデーターを読ますためのNO、D列 会社の個人コード、 E列 名字(シートへリンクさせてます。) F 名前・・・・G.H.・・・と他のデータがあります。 行は、 60行位です。 A.............B.....,,...,,..C............D...................E.............F...........G 1..........出勤数.......週払..........No..............コード............氏名..............勤務地 2...........20.............................1 ..............35982.......... 田中 太郎......... 日本会社 3...........1.............................2 ...............358055..........田中 花子.........日本会社 4............2.............................5...............39488........林 太郎.......... 日本会社..... リンク先を印刷するマクロは、こんな感じでよいのでしょうか? あと どのようにしてA列を検索してE列のリンク先を、印刷させるのかわかりません。 Range("E3").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True ExecuteExcel4Macro "PRINT(1,1,2,,,TRUE,,FALSE)" End Sub 印刷だけクリアー出来れば、出来上がりにしようと思っていますが、 いろいろ ネットや本で探しても 基本の検索や質問の仕方が 分からないので お手上げ 状態です。 力を貸してください。 お願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルでアクセスのようにリンクを貼って参照する方法
まず、私はオフィス系のソフトには素人なので、分かりにくい質問になるかと思いますが、何卒ご容赦くださいませ。 仕事先で、これまで名札を作る際に、アクセスを使用して来客者様の名札を作成していたのですが、諸事情によりアクセスが入ったPCが全て一時的に使えなくなってしまいました。 ですが、明後日までに100名近い名札を作成せねばならず、エクセルでもできないかと思い相談させていただいた次第になります。 これまでは、所定のmdbファイルを起動させると、お客様の会社名や役職・氏名などを入力するフォームが表示され、そこに情報を記入していき、 最後まで記入してそのウィンドウ?を閉じると「テーブルが更新されます」というような表示が出て、その後、フォームにある印刷プレビューというボタンを押すと A4用紙に名刺のような表示で順番に10人分のお客様の情報が並んだものが表示され、更に印刷を押すとそのレイアウト通りに印刷されるというものを使用しておりました。 例えば ○○株式会社 営業課長 ××株式会社 企画室長 山田 太郎 山田 次郎 △△株式会社 営業部 □□株式会社 経理課チーフ 山田 三郎 山田 四郎 といった感じです。 幸いエクセルでお客様の情報はリストとして持っているので (A列:会社名 B列:役職 C列:名前) エクセルの別シートに同じようなサイズの枠線を作り、その中にワードアートのように文字を配置し、アクセスで印刷をしていたものと同じものを 作成したいと考えているのですが、そのようなことは可能なのでしょうか?セルのサイズを変更して、単純にデータがあるシートの該当セルをlookupで表示すればいいかなと思ったのですが、 一部縦書き表示の箇所があったり、単純に縮小して全体表示を選んで範囲内に収めると見栄えがとても悪くてとても名札としてお渡しできるようなものにはなりませんでした。 理想的にはワードアートで配置や色を設定して、その中の表示が、1つ目の枠内にはデータシートの1行目の情報が、2つ目の枠内には2行目が・・・という風にできればと思うのですが。 とても分かりにくい上に長い質問になってしまった本当に申し訳ないのですが、このままでは手動で一人ずつコピペで貼り付けていかなければならなくなり、時間的にもとても厳しくなってしまいますので 何卒ご助言のほど宜しくお願い申し上げます。
- ベストアンサー
- オフィス系ソフト
- 会議の議題に悩んでます!!
会議の議題に悩んでます!! 僕は営業ですが、全部署が集まる定例会議が毎月ありまして、その議題に悩んでます。 各部署が発言出来る良い議題のヒントがあれば、ドンドン教えてください。 【補足】 (今までの議題) 経費節約、社内改善案、エコ、売上げを上げるには、などがあり、各部署が発言できる、etc (会社情報) 全体で20人 雑貨商社
- 締切済み
- その他(ビジネス・キャリア)
お礼
上手くいきました ありがとうございます。 長時間お付き合いさせてすいませんでした。 ですが、本当に助かりました。 Wendy02さんのような方がいらっしゃって本当に感謝しております。 本当にありがとうございました。