[[20151124175918]]　『略称を無くして読み込むには』（taka）　ページの最後に飛ぶ

『略称を無くして読み込むには』（taka）

H2以降データがあります。
　　　　H
2　　(株)○△
3　　（株）□○　’（株）機種依存文字
4　　（有）○○　’（株）機種依存文字
5　　空白
6　　（有）□○◎
以下続く

ListBox表示
　○△
　□○
　○○
　空欄は表示しない（無視詰める）
　□○◎

更にこの表示が50音順にソートされて表示出来れば
いいのですが

ListBoxに読み込み時略称以下
"??", "(有)", "(有）", "(財)", "（財）", "??", "(株)", "（株）"を
カッコが全角・半角・機種依存の株　有など
無視して読み込みたいのですがご教授ください。
よろしくお願いします。

Private Sub UserForm_Initialize()

    Dim c As Object
    Dim r As Range
    Dim t As Range
    If Cells(2, 8).Value <> "" Then
        Set c = CreateObject("Scripting.Dictionary")
        Set t = Range("H2", Cells(Rows.Count, "H").End(xlUp))
        On Error Resume Next
        For Each r In t
            c.Add r.Value, 0
        Next
        On Error GoTo 0
        Me.ListBox1.List = c.keys
    Else
        MsgBox "データがありません", vbExclamation
        Me.ListBox1.AddItem "デフォルト値"
    End If
End Sub

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

 まず、今、コードを書いてみて、コード内で環境依存文字を入力しようとすると、入力できるものと
 ? になってしまい、個別指定ができない文字があります。　
 なので、以下の例では、シート上の、どこかに（株）等の無視したい略称を入力したリストをつくり
 そこに名前定義で、　リスト　という名前を付けておくことを前提にしています。

 正規表現で一発変換も可能かと思いますがエスケープ文字のパターン構築が面倒なので愚直にループ。

 Private Sub UserForm_Initialize()
    Dim c As Range
    Dim d As Variant
    Dim s As String
    With CreateObject("System.Collections.ArrayList")
        For Each c In Range("H2", Range("H" & Rows.Count).End(xlUp))
            s = c.Value
            For Each d In Range("リスト").Value
                s = Replace(s, d, "")
            Next
            .Add s
        Next
        .Sort
        ListBox1.List = .toarray
    End With
 End Sub

（β） 2015/11/24(火) 19:10

 ↑　５０音順にはソートされないと思いますが。

（β） 2015/11/24(火) 19:35

（β）さん
ありがとうございます。
ListBoxに表示は出来たのですが
よくわからないのですが、データ自体は表示したのですが
ListBoxの一番下からデータが埋め込まれています？
（H列データ範囲は約800行です）
上から表示出来ますか？
(株)　（株）特定文字は問題なく表示しておりません。

しかし私のミスで１つ書き忘れていますが、同じ社名が
いくつか含まれます、依って同一会社は１つ候補にできないでしょうか
よろしくお願いします。
（taka） 2015/11/24(火) 19:45

＞５０音順にはソートされないと思いますが。
50音順ではないですがカタカナ・漢字でうまく整列できています。
報告です。

（taka） 2015/11/24(火) 19:48

 >>ListBoxの一番下からデータが埋め込まれています？ 
 >>（H列データ範囲は約800行です） 
 >>上から表示出来ますか？

 よくわからないのですが、下から表示されているとは、どういう現象ですか？

 >>同一会社は１つ候補にできないでしょうか

 （株）山田　と　(有)山田　があったとして、それも同じとみなされていいですか？

（β） 2015/11/24(火) 20:02

えーと！
リストボックスの最下行、右のスクロースバーを一番下にすると
社名が現れます。なんか変でしょうか

＞（株）山田　と　(有)山田　があったとして、それも同じとみなされていいですか？
きわめてレアなケースで問題ありません。
（このケースは（株）(有)同名はなしと考えて構いません）
よろしくお願いします。

（taka） 2015/11/24(火) 20:08

（β）さん
もう一つ報告ですが
空白行がListBoxの上位にいるようです、それなので
入力がある社名が下になるようです、違っていたらすみません。

（taka） 2015/11/24(火) 20:17

 >>リストボックスの最下行、右のスクロースバーを一番下にすると 
 >>社名が現れます。なんか変でしょうか

 >>空白行がListBoxの上位にいるようです

 ごめんなさい。状況がよくわかりません。
 こちらでは、とにかくフォームが表示された時点で、リストボックスに略称がカットされた社名がリストアップされていますが？
 もちろん、スクロールバーで、どんどん下にスクロールできます。

 そちらでは、リストボックスが空白で、ずっと下までスクロールさせるとデータが出てくるということでしょうか？
 考えにくいですねぇ。社名は H2 から始まっているんですよね？

 同名無視の件、

 .Add s

 これを

 If Not .contains(s) Then .Add s

 に変更・

（β） 2015/11/24(火) 20:19

 以下のコードを実行して、メッセージで表示される社名領域が正しいかどうか確認してください。
 で、もし正しければ、その中に　無視する略称だけのセルがないかどうかチェックしてください。

 Sub 確認()
    MsgBox Range("H2", Range("H" & Rows.Count).End(xlUp)).Address
 End Sub

（β） 2015/11/24(火) 20:23

報告です。
＞If Not .contains(s) Then .Add s
変更し、実行しました　結果ですが上一行分空き２行目から
表示しました、なぜ１行空くかは不明です。

確認コード実行　$H$2:$H$1000　です。
＞無視する略称だけのセルがないかどうかチェックしてください。
これについてはありませんでした。
以上です　よろしくお願いします。

（taka） 2015/11/24(火) 21:00

$H$2:$H$1000　全て文字埋込テストした結果
最上段からリストを表示します。なので
空白行が最上位に有るのでは無いでしょうか？
わかりませんが・・・

（taka） 2015/11/24(火) 21:07

 >>変更し、実行しました　結果ですが上一行分空き２行目から 
 >>表示しました、なぜ１行空くかは不明です。

 つまり、今までは（なぜか）空白の行が何行かあって、並び替えの結果それが先頭にきている。
 で、今回、同じ値はリストに加えるのをスキップした結果、空白が１行だけになって２行目から社名。

 ということは、どこかに　（略称を取り除いたあとの文字列が）空白のセルがいくつか、領域内にあるということです。

 >>$H$2:$H$1000　全て文字埋込テストした結果

 この意味がわかりません。
 あらためて　字埋込　せずとも、もともと、1000行目まで、何かしら値があるとマクロは認識しています。
 もしかしたら、数式なんかが入っているんですか？

 数式が入っていて "" になっているなら

 If Not .contains(s) Then .Add s

 を、さらに以下に。

 If Not .contains(s) And s <> "" Then .Add s

（β） 2015/11/24(火) 21:15

 漢字、半角/全角　ひらがな/カタカナ、英数文字以外を削除
 上手くソートできるか不明
 Private Sub UserForm_Initialize()
    Dim a() As String, n As Long, e, temp As String
    Dim i As Long, ii As Long
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w]+"
        For Each e In Range("h2", Range("h" & Rows.Count).End(xlUp)).Value
            temp = .Replace(e, "")
            If temp <> "" Then
                n = n + 1
                ReDim Preserve a(1 To n): a(n) = temp
            End If
        Next
    End With
    For i = 1 To n - 1
        For ii = i + 1 To n
            If a(i) > a(ii) Then
                temp = a(i): a(i) = a(ii): a(ii) = temp
            End If
        Next
    Next
    Me.ListBox1.List = a
End Sub
（seiya） 2015/11/24(火) 21:33

 >>$H$2:$H$1000　全て文字埋込テストした結果

 >この意味がわかりません
$H$2:$H$1000　←空白を無くし全て社名など埋め込んでテストしました。と
言うことを報告したつもりでした。
If Not .contains(s) And s <> "" Then .Add s
↑でListBoxの１行目の空白はなくなりました。安心しました。
もう少しテストしてみます。

ちょっとPCから離れなくてはならなくなりましたので確認しておきたいのですが

別の列に同様にListBox表示する場合（こちらは省略文字がありません）
この場合以下で、●部分を消去すればいいですか？わがまま言ってすみません

 Private Sub UserForm_Initialize()
    Dim c As Range
    Dim d As Variant
    Dim s As String
    With CreateObject("System.Collections.ArrayList")
        For Each c In Range("H2", Range("H" & Rows.Count).End(xlUp))
            s = c.Value
            For Each d In Range("リスト").Value　●
                s = Replace(s, d, "")
            Next　●
            .Add s
        Next
        .Sort
        ListBox1.List = .toarray
    End With
 End Sub

後ほど　報告させてください。
（taka） 2015/11/24(火) 21:34

 >>↑でListBoxの１行目の空白はなくなりました。安心しました。
 >>もう少しテストしてみます

 なぜ、こうなったか、理由は理解していただいてますか？

 Range("H2", Range("H" & Rows.Count).End(xlUp))

 社名領域ですが、H2 から H列のデータ最終行。で、この最終行が H1000 になっているようです。
 マクロは、2行目から1000行目まで、「ぎっしりと社名が埋まっている」と認識しています。
 でも実際には、下のほう、「空白セル」なんでしょうね。ただ、この「空白セル」が【見かけ上の空白セル】
 本当の「空白」ではなく、""(長さセロの文字列）が入っているんですよね。
 ここが数式でそうなっているのか、どこかからコピペした際に、そのコピペ元がそうなっていたのかわかりませんが。

 ですから、"" のものはリストに加えないという措置が必要だったわけです。

 ということが、他の列にもあるなら、追加質問に対する回答案もそれなりのものにしなければいけません。
 他の列ではそんなことがないなら、かつ、並び替えも不要ならリストボックスには１行でデータを登録できます。

（β） 2015/11/24(火) 23:07

（β）さん
やっと仕事から戻りました。お休みになってしまいましたでしょうか？
何度もいろいろ確認しました。
＞本当の「空白」ではなく、""(長さセロの文字列）が入っているんですよね。
＞ここが数式でそうなっているのか、どこかからコピペした際に、そのコピペ元がそうなっていたのかわかりませんが。
見た目空白にしか見えないですが、【""(長さセロの文字列）】そうなんですかね・・・
コピペもしていないし数式入れていません。ただ「ホーム」「テーブルとして書式設定」を1000行まで設定し見易い表にしているのと、インデント(左詰め)を設定しています。この辺でしょうか？
いずれにしてもうまくいきました。感謝です！
また別列も以下にしたところ思い通りです。。
間違いありますか？
Private Sub UserForm_Initialize()

    Dim c As Range
    Dim d As Variant
    Dim s As String
    With CreateObject("System.Collections.ArrayList")
        For Each c In Range("D2", Range("D" & Rows.Count).End(xlUp))
            s = c.Value
'            For Each d In Range("リスト").Value
                s = Replace(s, d, "")
'            Next
            If Not .contains(s) And s <> "" Then .Add s
        Next
        .Sort
        ListBox1.List = .toarray
    End With
End Sub
並び替え・重複の一本化は、必要です。

尚、βさんの書かれている
＞他の列ではそんなことがないなら、かつ、並び替えも不要ならリストボックスには１行でデータを登録できます。
こちらも今後の参考にしたいので教えていただけたら幸いです。
よろしくお願いします。

（seiya）さん
コードを提示いただきありがとうございます。
実行してみたところ、重複がそのまま表示されてしまいました、前にも書きましたが
重複は１つとしたいと考えています、また以下の部分の

        .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w]+"
ぁの左文字は文字化けでしょうかあまり見たことのない文字ですが本来はどの様に記載してあるのでしょうか？
よろしくお願いします。
（taka） 2015/11/25(水) 00:58

 >重複がそのまま表示されてしまいました、

 これで試してください。

 Private Sub UserForm_Initialize()
    Dim e, temp As String, AL As Object
    Dim i As Long, ii As Long
    Set AL = CreateObject("System.Collections.ArrayList")
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w]+"
        For Each e In Range("h2", Range("h" & Rows.Count).End(xlUp)).Value
            temp = .Replace(e, "")
            If (temp <> "") * (Not AL.Contains(temp)) Then AL.Add temp
        Next
    End With
    AL.sort_2 (CreateObject("System.Collections.CaseInsensitiveComparer"))
    Me.ListBox1.List = AL.ToArray
End Sub

 >        .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w]+"
 >ぁの左文字は文字化けでしょうかあまり見たことのない文字ですが本来はどの様に 記載してあるのでしょうか？
 >よろしくお願いします。

 文字化けではありません。
 漢字、半角/全角　ひらがな/カタカナ、英数文字、以外にヒットするはずです。

（seiya） 2015/11/25(水) 01:17

（seiya）さん
早速ありがとうございます。
試させていただきました、が
半角カタカナは表示されないようです
例
パナソニック(株)　　表示される→パナソニック
ﾊﾟﾅｿﾆｯｸ(株)　　　　表示されない→データが消去される

どれか足し引きしないといけませんか？
（taka） 2015/11/25(水) 01:35

  .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w\uFF61-\uFF9F]+"
 に変更してみてください。
（seiya） 2015/11/25(水) 01:55

（seiya）さんありがとうございます。
今度は、(株)→株が残ります。
パナソニック(株)→パナソニック株　となり
最初の　パナソニック　となりません。？

何度もすみませんがよろしくお願いします。
（taka） 2015/11/25(水) 02:22

         .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w\uFF61-\uFF9F]+|[株有]"
 に変更して、 必要であれば[株有]の部分に追加してみてください。
（seiya） 2015/11/25(水) 02:35

 こちらの方がいいかも

  Private Sub UserForm_Initialize()
    Dim e, temp As String, AL As Object
    Dim i As Long, ii As Long
    Set AL = CreateObject("System.Collections.ArrayList")
    With CreateObject("VBScript.RegExp")
        .Global = True
        For Each e In Range("h2", Range("h" & Rows.Count).End(xlUp)).Value
            .Pattern = "[^一-龠ぁ-んーァ-ヶＡ-Ｚａ-ｚ０-９\w\uFF61-\uFF9F]+"
            temp = .Replace(e, "")
            .Pattern = "^[株有]"
            temp = .Replace(temp, "")
            If (temp <> "") * (Not AL.Contains(temp)) Then AL.Add temp
        Next
    End With
    AL.Sort_2 (CreateObject("System.Collections.CaseInsensitiveComparer"))
    Me.ListBox1.List = AL.ToArray
End Sub
（seiya） 2015/11/25(水) 02:45

 >>ただ「ホーム」「テーブルとして書式設定」を1000行まで設定し見易い表にしているのと

 ということを、最初に説明があれば回り道しなくて済んだんですが、いずれにしても、テーブル化されていれば
 そうなりますね。で、対応済みの措置でＯＫになります。（逆にいえば、その措置が必要）

 で、別の列対応ですが、略称の削除は必要ないんですよね。
 必要なのは、並び替え・重複の一本化。

 とすると、s = Replace(s, d, "")　これも不要です。

 で、何もしないで、通常のデータがある範囲で　ある列の2行目からデータがある最終行までの内容をリストに一括セットする場合は

 ListBox1.List = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value

（β） 2015/11/25(水) 03:59

 ところで、これは個人の好みでしょうから、どうこういうことではないかもしれませんが
 あらかじめ１０００行目までを選んでテーブル化しておくことが、はたしていいのかなぁと思います。
 つまり、そのうちの８００行目までは実際に値が入っているけど、下のほうはからっぽ。
 なので、マクロ処理上、"" のチェックが必要。

 私なら、いったんテーブルを解除した上で、あらためてテーブルの値があるセルを選択して（たとえばＡ１）再設定。
 これで、実際に値がある部分だけがテーブル領域になります。（たとえば８００行目まで）

 そうすれば「見かけ上の空白」という心配をしなくてもよくなります。

 今後、８０１行目にデータを入力すれば自動的に、そこもテーブル領域になり、書式、数式等が継承されますので。

（β） 2015/11/25(水) 08:51

（β）さん
長々とありがとうございました。
思い通りの動作確認できました。
深夜にまでコメントいただき感激です。

（seiya）さん
ありがとうございました。
.Pattern = "[^一-龠ぁ-んーァ-ヶ・・・
こんなのあるんですね初めて見ました
VBAは奥が深いですね
勉強、勉強します。
これで解決と致します。

（taka） 2015/11/25(水) 10:36

コメント返信：

[ 一覧(最新更新順) ]

[[20151124175918]] 『略称を無くして読み込むには』（taka） ページの最後に飛ぶ

[[20151124175918]]　『略称を無くして読み込むには』（taka）　ページの最後に飛ぶ