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

クリップボードにある言葉を特定のセルに貼り付けたい。

エクセルに、画像のような一例の表があるとします。なお、列の項目はもっとありますし、項目は仮です。

クリップボードに、
[2017/9/8]
[目標]売上達成
[イベント]部長来店
[反省]部長が来たときに接客おろそかになった。

などとあったら、エクセルの該当日付の行に、それぞれ[]の後の言葉を貼り付け(値のみ)てもらいたいのです。クリップボード内の項目には必ず[ ]があるものとします。(表にはない)貼り付けるときに、[]の改行があるますべてを貼りけるものとします。

エクセルのマクロの方のみポイントをお渡しします。
どうかよろしくお願いいたします。



1504648298
●拡大する

●質問者: naranara19
●カテゴリ:学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● a-kuma3
●300ポイント ベストアンサー

こんな感じでどうでしょう。

' クリップボードのデータを、行単位の配列で返す
Function get_clipboard_data() As Variant
 Dim ret()
 Dim temp_sheet, target_sheet
 Set target_sheet = ActiveSheet
 Set temp_sheet = Worksheets.Add
 temp_sheet.Paste Range("a1")
 last_row = Cells(Rows.Count, 1).End(xlUp).Row
 ReDim ret(last_row)
 For r = 1 To last_row
 ret(r) = Cells(r, 1).Value
 Next
 get_clipboard_data = ret
 Application.DisplayAlerts = False
 temp_sheet.Delete
 Application.DisplayAlerts = True
 target_sheet.Activate
End Function

Sub set_data()
  ' クリップボードのデータを取得
 Data = get_clipboard_data()

  ' 日付を切り出し
 Set re = CreateObject("VBScript.RegExp")
 re.Pattern = "\[([^\]]+)\](.*)"
 Set m = re.Execute(Data(1))
 If m.Count = 0 Then
 Exit Sub
 End If
 report_date = m(0).submatches(0)

  ' 日付の行を探す
 last_row = Cells(Rows.Count, 1).End(xlUp).Row
 target_row = -1
 For r = 2 To last_row
 If Cells(r, 1).Text = report_date Then
 target_row = r
 Exit For
 End If
 Next
 If target_row = -1 Then
 Exit Sub
 End If

  ' 行タイトルと列の対応表を作る
 Set column_map = CreateObject("Scripting.Dictionary")
 last_col = Cells(1, Columns.Count).End(xlToLeft).Column
 For c = 2 To last_col
 column_map.Add Cells(1, c).Value, c
 Next

  ' 日付以外のデータをシートに埋め込む
 For i = 2 To UBound(Data)
 Set m = re.Execute(Data(i))
 If m.Count > 0 Then
 k = m(0).submatches(0)
 v = m(0).submatches(1)
 If column_map.exists(k) Then
 Cells(target_row, column_map.Item(k)).Value = v
 End If
 End If
 Next
End Sub

set_data サブルーチンを、該当のシートを選択した状態で実行です。

クリップボードからデータを取得するところが関数になってるのは、前の質問id:ken3memo さんが Microsoft Forms を使う回答をしていたので、そちらの方がお好みなら、この関数の部分を差し替えてください、ということで。


naranara19さんのコメント
早速ありがとうございます!のちほど確認してご返信します。いつもありがとうございます。

naranara19さんのコメント
ありがとうございます。 早速やってみたのですが、 実行時エラー'457' このキーは既にこのコレクションの要素に割り当てられています。 がでてしまい、 column_map.Add Cells(1, c).Value, c で止まってしまいます。 恐れ入りますが、教えていただけますでしょうか。

a-kuma3さんのコメント
シートの一行目で、重複しているものがあるのだと思います。 その重複している項目は、クリップボードから貼り付けるデータには含まれないのであれば、無視するようにしますが。

naranara19さんのコメント
いえいえ、ありがとうございました。確かにご指摘通り、私のミスで重複がありました。 感謝感謝です。お忙しい中リクエストにお応えいただき、本当に感謝しております。 今後ともよろしくお願いいたします。
関連質問

●質問をもっと探す●



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