[[20150729160633]]　『切り貼り 2』（choi）　ページの最後に飛ぶ

『切り貼り 2』（choi）

お世話になります。
[[20150428160902]] の応用ができずお助けください。
質問）
表１のＡ列－Ｂ列の組みで、Ａ列の文章から表２のように
“一つながりの”カタカナ（全角、半角）“のみ”バラして表示する

 －表１－
 A                B
 会社アイウ　     135
 A-3,ｶｷｸ,営）ｻｼｽ  Ca
 ＝タチ＝ツ＝     J9
 －表２－
 E                F
 アイウ           135　
 ｶｷｸ              Ca
 ｻｼｽ              Ca
 タチ             J9
 ツ               J9

説明）
・ネット上の表、文章などからＡ，Ｂ列にコピペします
・表１のデータ範囲は「A2-B500」までを想定
・表２のデータ範囲は「E2-F???」（表１の内容による）
・Ａ列の文章は一行に５０字程度までとします
・Ａ列の文章は全ての文字種を含みます
・Ａ列にあるカタカナは、区切られているとは限りません

返信遅れがちになるかも知れませんが、よろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

元のコードをブサイクに修正してしまって恐縮です。

 Sub とりあえず()
    Dim i As Long
    Dim ss As String, s As String
    Dim dic As Object
    Dim w As Variant
    Dim c As Range
    Dim d As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
        ss = ""
        For i = 1 To Len(c.Value)
            s = Mid(c.Value, i, 1)
            If StrConv(s, vbWide) = StrConv(StrConv(s, vbWide), vbHiragana) Then
                ss = ss & " "
            Else
                ss = ss & s
            End If
        Next

        w = Split(WorksheetFunction.Trim(ss))
        For Each d In w
            dic(dic.Count) = Array(d, c.Offset(, 1).Value)
        Next
    Next

    Range("E2").Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))

 End Sub

（マナ） 2015/07/29(水) 21:21

マナ様
ご回答ありがとうございます。
確認させていただきましたが、半全角の長音符？「ー」と半角の濁点「ﾞ」が
除外されるようです。（カード、カバー、ﾊﾞｰｺｰﾄﾞなど）
こちらでも考えてみますが、かなりハードルが高く．．．
（choi） 2015/07/30(木) 09:05

追記-17:38
提示いただいたコードに業務そっちのけでチャレンジしました。
一応うまくいってるようですが、何せ文字通り他の人からの
“切り貼り”なので今ひとつ自信が持てません。
詳しい方、マチガイ、改善点など添削お願いできないでしょうか？

Sub Test()

    Dim i As Long
    Dim ss As String, s As String
    Dim dic As Object
    Dim w As Variant
    Dim c As Range
    Dim d As Variant
    Dim objRE As Object

    Set dic = CreateObject("Scripting.Dictionary")
    Set objRE = CreateObject("VBScript.RegExp")

    With objRE
        .Pattern = "[\uFF61-\uFF9F\u30A1-\u30F6ー]+"       '全半角
        .IgnoreCase = True
        .Global = True
    For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
     ss = ""
      For i = 1 To Len(c.Value)
       s = Mid(c.Value, i, 1)
        If .Test(s) = False Then
          ss = ss & " "
         Else
          ss = ss & s
        End If
      Next
      w = Split(WorksheetFunction.Trim(ss))
       For Each d In w
        dic(dic.Count) = Array(d, c.Offset(, 1).Value)
       Next
    Next
    End With
    Set objRE = Nothing
    Range("E2").Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
 End Sub

ごめんなさい。修正難しかったでしょうか。

 気持ちとしては出きるだけ簡単なコードにしているつもりですが。

 Sub とりあえず3()
    Dim i As Long
    Dim ss As String, s As String
    Dim dic As Object
    Dim w As Variant
    Dim c As Range
    Dim d As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
        ss = c.Value
        For i = 1 To Len(ss)
            s = Mid(ss, i, 1)
            If StrConv(s, vbWide) = StrConv(StrConv(s, vbWide), vbHiragana) _
                And Not s Like "[ﾞﾟｰー]" Then
                Mid(ss, i, 1) = " "
            End If
        Next

        w = Split(WorksheetFunction.Trim(ss))
        For Each d In w
            Do While d Like "ー*"
                d = Mid(d, 2)
            Loop
            If Len(d) > 1 Then dic(dic.Count) = Array(d, c.Offset(, 1).Value)
        Next
    Next

    Range("E2").Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))

 End Sub

（マナ） 2015/07/30(木) 17:38

正規表現使うならセル単位で評価すればどうでしょうか。
１文字ずつであれば、最後の"+"は意味無いような気がします。たぶん。

（マナ） 2015/07/30(木) 19:34

苦手だけど、ちょっと考えてみました。
複雑なパターンは、私には無理。

        .Pattern = "[^\uFF61-\uFF9F\u30A1-\u30F6ー]+"
        .Global = True
        For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
            ss = .Replace(c.Value, " ")

            w = Split(WorksheetFunction.Trim(ss))

（マナ） 2015/07/30(木) 19:54

横入り失礼します。

 Sub test2()
     Dim dic As Object
     Dim c As Range
     Dim objRE As Object
     Dim matches As Object
     Dim m As Object

     Set dic = CreateObject("Scripting.Dictionary")
     Set objRE = CreateObject("VBScript.RegExp")

     With objRE
         .Pattern = "[\uFF61-\uFF9F\u30A1-\u30F6ー]+"       '全半角
         .IgnoreCase = True
         .Global = True
         For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
             Set matches = .Execute(c.Value)
             For Each m In matches
                 dic(dic.Count) = Array(m.Value, c.Offset(, 1).Value)
             Next
         Next
     End With

     Range("E2").Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
 End Sub

 ご指摘とおり、一文字ずつマッチさせるのは不経済です。
 なお、正規表現のパターンは詳しく見ていません。

（γ） 2015/07/30(木) 20:43

マナ様、γ様
ありがとうございます。　２案ともうまくいきました！

以前に区切り記号を目印に抽出する方法を学んだんですが、
今回のように“一つなぎ”で処理するのには一文字ずつ
マッチさせるのは理にかなってるかな．．と大いに参考に
なったんですが．．．

両方のやり方をご教示いただき、感謝します。

正規表現は？？？で、キチンと理解できるまでは無暗に？
使わない方がいいですかねぇ～
あるいは“火傷”負うのも精進のためにはいいかも．．．とか。

これからもよろしくお願いします。

（choi） 2015/07/30(木) 22:32

コメント返信：

[ 一覧(最新更新順) ]

[[20150729160633]] 『切り貼り 2』（choi） ページの最後に飛ぶ

[[20150729160633]]　『切り貼り 2』（choi）　ページの最後に飛ぶ