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

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


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

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

2名前

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

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

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


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


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



●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● a-kuma3
●200ポイント

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

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" で始まって、列の見出しに相当するような行がデータにあるんじゃないでしょうか?


naranara19さんのコメント
同じく Worksheets(name).Cells(r, 2) = val で止まってしまうのです。

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

2 ● きゃづみぃ
●50ポイント

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の名前が消えてしまいますね。


a-kuma3さんのコメント
>> というようなデータがあった場合、2の名前が消えてしまいますね。 << うげ。そう来たか。 でも、このコードだと、元の質問にあった以下のデータを正しく処理できませんよね。 >|txt| 15名前 15品物バナナ 15説明量が多いです ||<

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

質問者から

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

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

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

と、


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

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

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

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


3 ● きゃづみぃ
●50ポイント

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

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

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


きゃづみぃさんのコメント
あと ちょっとみてみて 気になる点があったので 修正します。 If Trim(val) = "" Then '変更箇所 の行を If Trim(val) = "" Or r = 0 Then '変更箇所 としてみたらいかがでしょうか?

a-kuma3さんのコメント
r = 0 は、ありそうですね。

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開始価格など、価格部分等に数字が入るところは 関係ありますでしょうか? 改行はされております。(テクスト上にて)

4 ● きゃづみぃ
●200ポイント ベストアンサー

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

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


naranara19さんのコメント
ありがとうございました。エラーは特に出ないのですが、エクセルシートへ何も貼り付けできていない状況です。

きゃづみぃさんのコメント
2名前青森県産終わり 2品物りんご終わり 2説明無農薬です終わり 2自社カテゴリよよよよ 2名前 15名前 15品物バナナ終わり 15説明量が多いです これをコピーして 実行 (mainを起動)してみてください。

きゃづみぃさんのコメント
あと ons というシートは ありますよね?

naranara19さんのコメント
ご指摘ありがとうございました!すみません。私のミスで、 onsシートの名前が変わっていました!! 新しくつくりかえていただいたものですが、起動しました! 良いのですが、 1行目は、見出しでして、1行目の見出しから上書きして、貼り付けられてしまいます。 1段下から貼り付けられるようにお願いできますでしょうか? 1名前等はすべて2行目です。15説明などは16行目貼り付けということです。 もう少しで終わりそうです。ご協力に感謝します!

きゃづみぃさんのコメント
d3 = CLng(d2) ↓ d3 = CLng(d2) +1

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

●質問をもっと探す●



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