1331193307 エクセルVBAで、「 クリップボード上にある文章から、エクセルシートにそれぞれ貼り付けしたい。



「文章」というシートのA1内に長い文章があります(可能な文字数)

その中が、以下のような感じだとします。


「1名前」和歌山県産「終わり」
「1品物」みかん「終わり」
「1説明」とても甘いです「終わり」

「2名前」青森県産「終わり」
「2品物」りんご「終わり」
「2説明」無農薬です「終わり」



「15名前」「終わり」
「15品物」バナナ「終わり」
「15説明」量が多いです「終わり」


数字は一応50くらいまで。難しいのであれば、20までとします。数字は全角の場合もあります。「」はわかりやすくするためで本来はありません。終わりという言葉で区切りをつけていますが、必要なければ、なくても判定していただける方がベターです。(「終わり」を一切無視してOKです)



【VBAマクロ】
そこでマクロをはじめると、
「ons」というシート名の各場所に振り分けてコピー&ペースト(上書き)できるようにしてほしいのです。


【貼り付け先の該当場所は画像をご参考にお願いします】


どうかよろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2012/03/08 16:55:09
  • 終了:2012/03/08 22:13:44

ベストアンサー

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/03/08 18:15:56

ポイント300pt

コメントいただいた要件を実行できるようにマクロを修正しました。

VBAでクリップボードを扱うための前準備

  1. 開発 → マクロ → VisualBasic
  2. VisualBasicEditerで ツール → 参照設定
  3. 参照設定で Microsoft Forms 2.0 Object Library にチェックを入れてください。

Microsoft Forms 2.0 Object Libraryが見つからない場合は、以下のサイトを参考にしてください。
http://pc.k-solution.info/programming/vba/excelvba1.aspx

マクロ本体

クリップボードの内容に「」や「終わり」は含まれておらず、以下のようになっているとします。
数字の制限は設けていません。(メモリが許す限りOKのはず)
ただし、数字の次に、名前, 品物, 説明 のいずれかの文字があることが前提です。また、シート "ons" が存在していることが前提です。(シートの内容をクリアせず、そのまま代入するようにしてあります)

1名前
和歌山県産

1品物
みかん

1説明
とても
甘いです

2名前青森県産
2品物りんご
2説明無農薬です

ただし、次のようなクリップボードは正常に処理できません。
数字+名前, 品物, 説明のいずれかの文字が同じ行になっていることが前提です。

1名前和歌山
県産

1品物
みかん

1説明とても
甘いです



マクロは次のようになります。

Option Explicit

'クリップボードの内容を取り出す
Function getClipBoard() As String
    Dim CB As Object
    Set CB = New DataObject
    With CB
        .GetFromClipboard
        getClipBoard = .GetText
    End With
End Function

Sub main()
    Dim str As String, items() As String
    Dim i As Long, j As Long, r As Long
    Dim re As Object
    Dim remat As Variant
    Dim key As String, val As String, name As String
    
    name = "ons"                                     'シート名
    str = getClipBoard()
    items = Split(str, vbCrLf)
    Set re = CreateObject("VBScript.RegExp")
    For i = LBound(items) To UBound(items)
        With re
            .Pattern = "([0-9]+)(名前|品物|説明)(.*)"
            .IgnoreCase = True
            .Global = True
            Set remat = .Execute(items(i))
            If remat.Count > 0 Then
                r = remat(0).SubMatches(0) + 1       '行番号
                key = remat(0).SubMatches(1)         '見出し
                val = remat(0).SubMatches(2)         'データ
                If (val = "") Then
                    i = i + 1
                    While (i <= UBound(items) And items(i) <> "")
                        val = val & items(i) & vbCrLf
                        i = i + 1
                    Wend
                    val = Left(val, Len(val) - 1)
                End If
                Select Case key
                    Case "名前"
                        Worksheets(name).Cells(r, 2) = val
                  Case "品物"
                        Worksheets(name).Cells(r, 3) = val
                    Case "説明"
                        Worksheets(name).Cells(r, 9) = val
               End Select
            End If
        End With
    Next i
    Set re = Nothing
End Sub


他1件のコメントを見る
id:oil999

マクロを修正しました。お試しください。

2012/03/08 21:25:00
id:naranara19

ありがとうございました!とても助かりました。今後もぜひ何か質問したときには、お答えいただけたらうれしいです!

2012/03/08 22:13:08

その他の回答(1件)

id:oil999 No.1

oil999回答回数1728ベストアンサー獲得回数3202012/03/08 18:15:56ここでベストアンサー

ポイント300pt

コメントいただいた要件を実行できるようにマクロを修正しました。

VBAでクリップボードを扱うための前準備

  1. 開発 → マクロ → VisualBasic
  2. VisualBasicEditerで ツール → 参照設定
  3. 参照設定で Microsoft Forms 2.0 Object Library にチェックを入れてください。

Microsoft Forms 2.0 Object Libraryが見つからない場合は、以下のサイトを参考にしてください。
http://pc.k-solution.info/programming/vba/excelvba1.aspx

マクロ本体

クリップボードの内容に「」や「終わり」は含まれておらず、以下のようになっているとします。
数字の制限は設けていません。(メモリが許す限りOKのはず)
ただし、数字の次に、名前, 品物, 説明 のいずれかの文字があることが前提です。また、シート "ons" が存在していることが前提です。(シートの内容をクリアせず、そのまま代入するようにしてあります)

1名前
和歌山県産

1品物
みかん

1説明
とても
甘いです

2名前青森県産
2品物りんご
2説明無農薬です

ただし、次のようなクリップボードは正常に処理できません。
数字+名前, 品物, 説明のいずれかの文字が同じ行になっていることが前提です。

1名前和歌山
県産

1品物
みかん

1説明とても
甘いです



マクロは次のようになります。

Option Explicit

'クリップボードの内容を取り出す
Function getClipBoard() As String
    Dim CB As Object
    Set CB = New DataObject
    With CB
        .GetFromClipboard
        getClipBoard = .GetText
    End With
End Function

Sub main()
    Dim str As String, items() As String
    Dim i As Long, j As Long, r As Long
    Dim re As Object
    Dim remat As Variant
    Dim key As String, val As String, name As String
    
    name = "ons"                                     'シート名
    str = getClipBoard()
    items = Split(str, vbCrLf)
    Set re = CreateObject("VBScript.RegExp")
    For i = LBound(items) To UBound(items)
        With re
            .Pattern = "([0-9]+)(名前|品物|説明)(.*)"
            .IgnoreCase = True
            .Global = True
            Set remat = .Execute(items(i))
            If remat.Count > 0 Then
                r = remat(0).SubMatches(0) + 1       '行番号
                key = remat(0).SubMatches(1)         '見出し
                val = remat(0).SubMatches(2)         'データ
                If (val = "") Then
                    i = i + 1
                    While (i <= UBound(items) And items(i) <> "")
                        val = val & items(i) & vbCrLf
                        i = i + 1
                    Wend
                    val = Left(val, Len(val) - 1)
                End If
                Select Case key
                    Case "名前"
                        Worksheets(name).Cells(r, 2) = val
                  Case "品物"
                        Worksheets(name).Cells(r, 3) = val
                    Case "説明"
                        Worksheets(name).Cells(r, 9) = val
               End Select
            End If
        End With
    Next i
    Set re = Nothing
End Sub


他1件のコメントを見る
id:oil999

マクロを修正しました。お試しください。

2012/03/08 21:25:00
id:naranara19

ありがとうございました!とても助かりました。今後もぜひ何か質問したときには、お答えいただけたらうれしいです!

2012/03/08 22:13:08
id:TransFreeBSD No.2

TransFreeBSD回答回数657ベストアンサー獲得回数2632012/03/08 19:53:24

ポイント100pt

まあoil999さんとほぼ一緒ですけど、こうですよね?
あと、ちょっと改良点も。

Option Explicit

Sub Macro1()
    Dim dst, re, match, culmun As String
    ' 以下2行をコメントアウトすると、現在選択中のセルを対象にする。
    Worksheets("文章").Activate
    Range("A1").Select
    ' 記入シートは以下で設定
    Set dst = Worksheets("ons")
    Set re = CreateObject("VBScript.RegExp")
    ' 改行で説明終わりなら、「終わり」は必要なく以下でOK
    re.Pattern = "([0-90-9]+)(名前|品物|説明)(.*)"
    ' 以下だと改行なしも説明とか「終わり」までに改行もOK
    're.Pattern = "([0-90-9]+)(名前|品物|説明)([\s\S]*?)終わり"
    re.Global = True
    For Each match In re.Execute(Selection.Value)
        Select Case match.SubMatches(1)
            Case "名前"
                culmun = "B"
            Case "品物"
                culmun = "C"
            Case "説明"
                culmun = "I"
        End Select
        dst.Range(culmun & match.SubMatches(0) + 1).Value = match.SubMatches(2)
    Next
End Sub

以下の代わりに

    re.Pattern = "([0-90-9]+)(名前|品物|説明)(.*)"

以下を使うと

    re.Pattern = "([0-90-9]+)(名前|品物|説明)([\s\S]*?)終わり"

以下のように、「終わり」が必要になりますが、途中で改行もokだし、改行なしでもokになります。

1名前和歌山県産終わり
1品物みかん終わり
1説明とても
甘いです終わり
2名前青森県産終わり2品物りんご終わり 12説明無農薬です終わり

id:naranara19

ありがとうございました!さっそくやったのですが、実行時のエラー9がでてしまいます。oil999さんのご回答はでないので、コードに何か問題があるのかもしれないです。途中改行に気づいてくれたことがとてもうれしいです。改行の件を打ち込んだあとにTransFreeBSDさんのご回答に気づきました。

2012/03/08 21:25:14

コメントはまだありません

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

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

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

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