文字抽出のＶＢＡ教えて頂きましたが、追加したいです。 再度教えて下さい。 A1セルに以下の文章が入っ

文字抽出のＶＢＡ教えて頂きましたが、追加したいです。
再度教えて下さい。

A1セルに以下の文章が入っています。


ゴムを全面に採用したワニモデルに新色登場。品番：X6X93A価　格：￥92,8AA+税ピコ：SS～M素材名：MOMIJI/本体=かいこ製　支え=毛皮製素敵な機能/ゴム底インナー機能/春ですね式（SAKURA）生産国：カナダ花粉症が始まる：CHI6A9・HIK799インディゴブルーｘインディゴブルー品　名：キリンXNewColorNewColorアリゲーターエックス49499A9Aブラックxブラックお菓子カレンダーEXSYゴムを全面に採用したワニレディスモデルに新色登場。品番：X6X33A価　格：￥92,8AA+税ピコ：22.5～26.A素材名：MOMIJI/本体=かいこ製　生産国：中国‥‥‥

本日教えていただいたVBAです。品番と生産国を無事抜き出す事ができました。

追加で生産国を抜き出したい場合はどこに何を付け加えればいいですか？？

マクロもできないくせに、こんな事聞いて本当にお恥ずかしいのですがこれができると業務が非常にシンプルになるなと思ったので、お力借りてばかりで申し訳ありませんが、また助けてください。お願いします。


''------
Sub SplitWordsR()
　Dim str_text As String
　Dim i As Long
　Dim buf1, buf2, buft
　str_text = Range("A1").Value
　buf1 = Split(str_text, "品番")
　buf2 = Split(str_text, "生産国")
　If UBound(buf1) <> UBound(buf2) Then
　　MsgBox "品番と生産国の数の対応がありません", vbExclamation
　　If MsgBox("それでも続行しますか？", vbOKCancel) = vbCancel Then Exit Sub
　End If
　Range("A3:B3").Value = Array("品番", "生産国")
　For i = 0 To UBound(buf1)
　On Error Resume Next
　　If Left(buf1(i), 1) Like "：" Then
　　　buft = buf1(i)
　　　Cells(3 + i, 1).Value = Mid(buft, 2, 7)
　　　''Debug.Print buft
　　　Cells(3 + i, 2).Value = Mid(Split(buft, "生産国")(1), 2, 7)
　　　buft = ""
　　End If
On Error GoTo 0
　Next
End Sub

質問者からの補足コメント

• 

  あーごめんなさい！！本当にミスが多くて申し訳ないです。
  慌ててしまいました。
  品番と生産国と素材名の間違いです。

    補足日時：2017/02/24 14:00

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2017/02/24 15:46

こんにちは。

Sub SplitWordsR2()
　Dim str_text As String
　Dim i As Long
　Dim buf1, buf2, buft
　str_text = Range("A1").Value
　buf1 = Split(str_text, "品番")
　buf2 = Split(str_text, "生産国")
　If UBound(buf1) <> UBound(buf2) Then
　　MsgBox "品番と生産国の数の対応がありません", vbExclamation
　　If MsgBox("それでも続行しますか？", vbOKCancel) = vbCancel Then Exit Sub
　End If
　Range("A3:C3").Value = Array("品番", "生産国", "素材名")
　For i = 0 To UBound(buf1)
　On Error Resume Next
　　If Left(buf1(i), 1) Like "：" Then
　　　buft = buf1(i)
　　　Cells(3 + i, 1).Value = Mid(buft, 2, 7)
　　　Cells(3 + i, 2).Value = Mid(Split(buft, "生産国")(1), 2, 7)
　　　If UBound(Split(buft, "素材名")) > 0 Then
　　　　Cells(3 + i, 3).Value = Mid(Split(buft, "素材名")(1), 2, 7)
　　　End If
　　　buft = ""
　　End If
On Error GoTo 0
　Next
End Sub
'//
素材名のところは、エラー処理をつけました。
万が一、そこがなくても、マクロは止まりません。

p.s.
>本当にミスが多くて申し訳ないです。

昔、30代の頃に、私もそういう状態が続いて、深刻な状態になったことがありました。単なるミスとかではありません。もう壊れる寸前だったと思います。

リラックス、リラックス。
こういう時に、自分の好きな音楽を聞くのが一番です。(それで治りました、本当です。）

昔、永六輔さんが、右脳と左脳の使用率がアンバランスだとよくないので、左脳を酷使したら、右脳を使うようにしなさい、と言っていました。外で走るだけでもよいのだそうです。逆も真なりだそうです。

つまらないことを言ってごめんなさい。

この回答へのお礼

無事完成しました。
本当にご親切にありがとうございました。初めての質問だったので非常に不安でしたが、こんなに親切に教えてもらえて涙が出そうです。何度も何度も申し訳ありませんでした。ありがとうございます。

お礼日時：2017/02/24 16:18

No.1 回答者： WindFaller 回答日時： 2017/02/24 13:56

すみませんが、追加の生産国とは？

生産国として、一通り抜き出しているのですが、もしかして、
Mid(Split(buft, "生産国")(1), 2, 7)

ここが、7文字、言い換えると、生産国：合衆国, オーストラリア
などになっているので、もう少し多く取り出したい、ということでしょうか。

もしそうなら、
Mid(Split(buft, "生産国")(1), 2, 15)　　←7の数を適当に増やす
ということになります。

コンマ(,）などが入っているようでしたら、別途切り分けすることは可能だと思います。