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



という以前の質問
http://q.hatena.ne.jp/1331193307

ですばらしいベストアンサーをいただいたのですが、
一部空白のときに、マクロが止まってしまいます。

2名前

など、どの項目でも、あとに何も入らない、もしくは空白のスペースがあった場合は、
とばして(つまりコピーはしない)次の動作にうつってマクロを完了させるには

どうしたらよいでしょうか?

ベストアンサーの方にリクエストしますが、
もしご回答いただけない場合は他の方でも私はかまいません。


お手数ですが、前回のベストアンサーのコードは基本変えずに一部置き換えや、追加で対応できるように
してくださいますようお願いいたします。


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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/03/20 14:35:42
  • 終了:2013/03/21 20:48:01

ベストアンサー

id:taknt No.4

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/03/20 19:14:35

ポイント200pt

元のソースが イマイチだったので 作り変えました。

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
    Dim re As Object
    Dim key As String, name As String
    
    name = "ons"                                     'シート名
    str = getClipBoard()
    items = Split(str, vbCrLf)

    For i = LBound(items) To UBound(items)
        Call setdata(items(i), "名前", name, 2)
        Call setdata(items(i), "品物", name, 3)
        Call setdata(items(i), "自社カテゴリ", name, 4)
        Call setdata(items(i), "送料", name, 8)
        Call setdata(items(i), "説明", name, 9)
        Call setdata(items(i), "カテゴリ", name, 14)
        Call setdata(items(i), "開始価格", name, 20)
        Call setdata(items(i), "希望価格", name, 65)
    Next i
End Sub

Sub setdata(a As String, c As String, name As String, d As Integer)
Dim d1 As String
Dim d2 As String
Dim d3 As Long
Dim val As String

    d1 = InStr(a, c)
    If d1 > 0 Then
        d2 = Left(a, d1 - 1)
        On Error GoTo errtrns
        d3 = CLng(d2)
        val = Right(a, Len(a) - d1 + 1)
        If Right(val, Len("終わり")) = "終わり" Then
            val = Left(val, Len(val) - Len("終わり"))
        End If
        
        If Left(val, Len(c)) = c Then
            val = Right(val, Len(val) - Len(c))
            If Trim(val) <> "" Then
                Worksheets(name).Cells(d3, d) = val
            End If
        End If
errtrns:
        a = ""
    End If
End Sub

他4件のコメントを見る
id:taknt

d3 = CLng(d2)


d3 = CLng(d2) +1

2013/03/21 06:08:39
id:naranara19

ありがとうございました!お二人とも回答がばっちりなのですが、きゃづみぃさんのおかげでわかった部分がたくさんあったため、きゃづみぃさんを「いるか賞」にさせていただきますね。お二人とも本当にありがとうございました。

2013/03/21 20:46:54

その他の回答(3件)

id:a-kuma3 No.1

a-kuma3回答回数4487ベストアンサー獲得回数18562013/03/20 16:03:13

ポイント200pt

こんな感じのデータが混じっても、正しく処理できるようにしてみました。

15名前
15品物バナナ
15説明量が多いです

マクロはこちら。行末に '★ をつけた行を追加しています。

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
                    Set remat = .Execute(items(i + 1))      ' ★
                    If remat.Count = 0 Then                 ' ★
                        i = i + 1
                        While (i <= UBound(items) And items(i) <> "")
                            val = val & items(i) & vbCrLf
                            i = i + 1
                        Wend
                        If val <> "" Then                   ' ★
                            val = Left(val, Len(val) - 1)
                        End If                              ' ★
                    End If                                  ' ★
                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




質問の補足を受けての追記です。

対象のカラムを増やした分について、回答に書いたコードを変えてみましたが、特に処理が止まるような感じがしません。

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
                    Set remat = .Execute(items(i + 1))          ' ★
                    If remat.Count = 0 Then                     ' ★
                        i = i + 1
                        While (i <= UBound(items) And items(i) <> "")
                            val = val & items(i) & vbCrLf
                            i = i + 1
                        Wend
                        If val <> "" Then                       ' ★
                            val = Left(val, Len(val) - 1)
                        End If                                  ' ★
                    End If                                      ' ★
                End If
                Select Case key                                     '◎ ここから後を変更...
                    Case "名前"
                        Worksheets(name).Cells(r, 2) = val
                    Case "品物"
                        Worksheets(name).Cells(r, 3) = val
                    Case "自社カテゴリ"
                        Worksheets(name).Cells(r, 4) = val
                    Case "送料"
                        Worksheets(name).Cells(r, 8) = val
                    Case "説明"
                        Worksheets(name).Cells(r, 9) = val
                    Case "カテゴリ"
                        Worksheets(name).Cells(r, 14) = val
                    Case "開始価格"
                        Worksheets(name).Cells(r, 20) = val
                    Case "希望価格"
                        Worksheets(name).Cells(r, 65) = val
                End Select
            End If
        End With
    Next i
    Set re = Nothing
End Sub

もしかしたら、行の頭が "0" で始まって、列の見出しに相当するような行がデータにあるんじゃないでしょうか?

id:naranara19

同じく Worksheets(name).Cells(r, 2) = val
で止まってしまうのです。

2013/03/20 19:08:19
id:naranara19

a-kuma3さんと、きゃづみぃさんにはお手数をおかけしました!きゃづみぃさんのコメント欄にありますとおり、シート名を間違えておりました。すみません。きちんと、2行目から貼付できました。ほんとに感謝します!!ありがとうございます。

2013/03/21 11:42:15
id:taknt No.2

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/03/20 17:58:32

ポイント50pt

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
                    If Trim(val) = "" Then          '変更箇所
                        key = ""                    '変更箇所
                    Else                            '変更箇所
                        val = Left(val, Len(val) - 1)
                    End If                           '変更箇所
                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

No.1の回答だと

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

というようなデータがあった場合、2の名前が消えてしまいますね。

id:a-kuma3

というようなデータがあった場合、2の名前が消えてしまいますね。

うげ。そう来たか。
でも、このコードだと、元の質問にあった以下のデータを正しく処理できませんよね。

15名前
15品物バナナ
15説明量が多いです
2013/03/20 18:40:42
id:naranara19

はい。そうなので、その場合は15名前はカットしてからコピーし、読み込ませておりました。

2013/03/20 19:07:30
id:naranara19

ご丁寧にありがとうございます。

お二人とも試してみたのですが、
実は例のベストアンサーの方の回答に、

(名前|品物|自社カテゴリ|送料|説明|カテゴリ|開始価格|希望価格)

と、


Case "名前"
Worksheets(name).Cells(r, 2) = val
Case "品物"
Worksheets(name).Cells(r, 3) = val
Case "自社カテゴリ"
Worksheets(name).Cells(r, 4) = val
Case "送料"
Worksheets(name).Cells(r, 8) = val
Case "説明"
Worksheets(name).Cells(r, 9) = val
Case "カテゴリ"
Worksheets(name).Cells(r, 14) = val
Case "開始価格"
Worksheets(name).Cells(r, 20) = val
Case "希望価格"
Worksheets(name).Cells(r, 65) = val

と変えて使えるようにしていたのです。

お二人ともこれでマクロを動かすと、ともに、同じ箇所の、

Case "名前"
Worksheets(name).Cells(r, 2) = val

で止まってしまうのです。

置き換えや追加でお願いしていたのはそういう意味でして、
お手数ですがもう少しご教授いただけますでしょうか?

なお、お二人ともポイントはしっかりとお支払します。

id:taknt No.3

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/03/20 18:37:01

ポイント50pt

Select Case key
の前に
Debug.Print "name = " & name
Debug.Print "r = " & CStr(r)
Debug.Print "val = " & val

を入れて エラーでとまったときに 最後に表示されたものを 教えてください。

ま、できれば テストしたデータを教えてもらったほうが 早いですけどね。

他1件のコメントを見る
id:a-kuma3

r = 0 は、ありそうですね。

2013/03/20 18:41:54
id:naranara19

ありがとうございました。

Debug.Print "name = " & name
Debug.Print "r = " & CStr(r)
Debug.Print "val = " & val


と、

If Trim(val) = "" Or r = 0 Then '変更箇所


をともに変更したときには、

やはり、
Worksheets(name).Cells(r, 2) = val
が黄色くなりエラーとなってしまいます。

0行からはじまるものは特にないのですが、1開始価格など、価格部分等に数字が入るところは
関係ありますでしょうか?
改行はされております。(テクスト上にて)

2013/03/20 19:42:31
id:taknt No.4

きゃづみぃ回答回数13538ベストアンサー獲得回数11982013/03/20 19:14:35ここでベストアンサー

ポイント200pt

元のソースが イマイチだったので 作り変えました。

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
    Dim re As Object
    Dim key As String, name As String
    
    name = "ons"                                     'シート名
    str = getClipBoard()
    items = Split(str, vbCrLf)

    For i = LBound(items) To UBound(items)
        Call setdata(items(i), "名前", name, 2)
        Call setdata(items(i), "品物", name, 3)
        Call setdata(items(i), "自社カテゴリ", name, 4)
        Call setdata(items(i), "送料", name, 8)
        Call setdata(items(i), "説明", name, 9)
        Call setdata(items(i), "カテゴリ", name, 14)
        Call setdata(items(i), "開始価格", name, 20)
        Call setdata(items(i), "希望価格", name, 65)
    Next i
End Sub

Sub setdata(a As String, c As String, name As String, d As Integer)
Dim d1 As String
Dim d2 As String
Dim d3 As Long
Dim val As String

    d1 = InStr(a, c)
    If d1 > 0 Then
        d2 = Left(a, d1 - 1)
        On Error GoTo errtrns
        d3 = CLng(d2)
        val = Right(a, Len(a) - d1 + 1)
        If Right(val, Len("終わり")) = "終わり" Then
            val = Left(val, Len(val) - Len("終わり"))
        End If
        
        If Left(val, Len(c)) = c Then
            val = Right(val, Len(val) - Len(c))
            If Trim(val) <> "" Then
                Worksheets(name).Cells(d3, d) = val
            End If
        End If
errtrns:
        a = ""
    End If
End Sub

他4件のコメントを見る
id:taknt

d3 = CLng(d2)


d3 = CLng(d2) +1

2013/03/21 06:08:39
id:naranara19

ありがとうございました!お二人とも回答がばっちりなのですが、きゃづみぃさんのおかげでわかった部分がたくさんあったため、きゃづみぃさんを「いるか賞」にさせていただきますね。お二人とも本当にありがとうございました。

2013/03/21 20:46:54

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

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

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

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