Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11692 / 13645 ツリー ←次へ | 前へ→

【14569】セルの文字列データの種類分けVBAコード しん 04/6/2(水) 2:37 質問[未読]
【14570】Re:セルの文字列データの種類分けVBAコード ichinose 04/6/2(水) 7:46 回答[未読]
【14575】Re:セルの文字列データの種類分けVBAコード しん 04/6/2(水) 10:31 回答[未読]
【14609】Re:セルの文字列データの種類分けVBAコード しん 04/6/3(木) 2:15 質問[未読]
【14612】Re:セルの文字列データの種類分けVBAコード ichinose 04/6/3(木) 8:12 発言[未読]
【14641】Re:セルの文字列データの種類分けVBAコード ichinose 04/6/3(木) 18:41 発言[未読]
【14669】Re:セルの文字列データの種類分けVBAコード しん 04/6/4(金) 0:45 お礼[未読]
【14689】Re:セルの文字列データの種類分けVBAコード ichinose 04/6/4(金) 18:21 発言[未読]
【14695】Re:セルの文字列データの種類分けVBAコード しん 04/6/5(土) 2:52 回答[未読]
【14698】Re:セルの文字列データの種類分けVBAコード しん 04/6/5(土) 12:07 回答[未読]

【14569】セルの文字列データの種類分けVBAコード
質問  しん  - 04/6/2(水) 2:37 -

引用なし
パスワード
   Excelワークシートのあるセルに下記のような任意の文字列データ

A02A02B12B13C22C22C23A02B13D345A02E99

が入っていたとき、この文字列を英文字を先頭にした文字列群に分解し、その個数を文字列名と共に知りたい、すなわち

A02:4, B12:1, B13:2, C22:2, C23:1, D345:1, E99:1

のような解答(文字列データ)を得たいのですが、どのようなVBAコードを書けばいいのでしょうか?

【14570】Re:セルの文字列データの種類分けVBAコー...
回答  ichinose  - 04/6/2(水) 7:46 -

引用なし
パスワード
   ▼しん さん:
おはようございます。

>Excelワークシートのあるセルに下記のような任意の文字列データ
>
>A02A02B12B13C22C22C23A02B13D345A02E99
>
>が入っていたとき、この文字列を英文字を先頭にした文字列群に分解し、その個数を文字列名と共に知りたい、すなわち
>
>A02:4, B12:1, B13:2, C22:2, C23:1, D345:1, E99:1
>
>のような解答(文字列データ)を得たいのですが、どのようなVBAコードを書けばいいのでしょうか?
以下の例はアクティブシートのセルE1に上記の

「A02A02B12B13C22C22C23A02B13D345A02E99」等の文字列が入っていた場合、

A列の1行目から「英文字を先頭にした文字列群」B列の1行目から「個数」を
セットします。
'======================================================================
Sub test()
  Dim co As Collection
  Dim ans()
  Call 文字列分解(Range("e1").Value, ans())
  Set co = mk_unique_collection(ans()) '重複なしの集合体の作成
  For idx = 1 To co.Count
   wk = Filter(ans(), co.Item(idx), , vbTextCompare)
   cnt = UBound(wk) - LBound(wk) + 1 '個数の計算
   Cells(idx, 1).Value = co.Item(idx)
   Cells(idx, 2).Value = cnt
   Next
  Set co = Nothing
End Sub
'=====================================================================
Sub 文字列分解(strng, a_array())
  Dim regEx, Match, Matches  ' 変数を作成します。
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = "[A-Za-z][0-9]*"
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  idx = 1
  For Each Match In Matches  ' Matches コレクションに対して繰り返し処理を行います。
   ReDim Preserve a_array(1 To idx)
   a_array(idx) = Match.Value
   idx = idx + 1
  Next
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
End Sub
'======================================================================
Function mk_unique_collection(myarray())
  Dim myclct As New Collection
  On Error Resume Next
  For idx = LBound(myarray()) To UBound(myarray())
   myclct.Add myarray(idx), myarray(idx)
   Next
  Set mk_unique_collection = myclct
  Set myclct = Nothing
  On Error GoTo 0
End Function

これでプロシジャー「test」を実行してみて下さい。
A列B列の1行目から、

A02    4
B12    1
B13    2
C22    2
C23    1
D345    1
E99    1

という結果が得られました。
確認してみて下さい。

【14575】Re:セルの文字列データの種類分けVBAコー...
回答  しん  - 04/6/2(水) 10:31 -

引用なし
パスワード
   ▼ichinose さん:
おはようございます。今朝はおかげさまで清々しい朝を迎えることができ、ありがとうございました。ここ数日悩みあぐねていた文字列処理がichinoseさんの素晴らしいVBAスーパーテクニックで解決できることを確認できました。世の中には凄い人がいるんだなと改めて認識した次第です。私の今の実力ではichinoseさんの書かれたコードの全容を理解することは難しいですが、わかる範囲を変更するだけでもいろいろな場面で使えそうな気がします。ほんとうに素晴らしいVBAコードありがとうございました。これからもよろしくご指導をお願いします。

【14609】Re:セルの文字列データの種類分けVBAコー...
質問  しん  - 04/6/3(木) 2:15 -

引用なし
パスワード
   ichinoseさんへ
こんばんは、しんです。今朝は大変感激してあらゆるデータ例を試してみなかったので気付かなかったのですが、もし題意の文字列が

A02A02B12B13C22C22C23C2A02B13D345A02E99C2

のような場合には、解答が

A02    4
B12    1
B13    2
C22    2
C23    1
C2    5
D345    1
E99    1

のようになってしまい、C2がC2自身とそれ以外のC2から始まる文字列群(C22やC23)まで仲間に入れてしまい、望む解答

A02    4
B12    1
B13    2
C22    2
C23    1
C2    2
D345    1
E99    1

になるようにするのには、VBAコードのどこをどう変えればいいのでしょうか、ご教示下さい。

また、もし、題意の文字列が

CCQM-K13,CCQM-K13,CCQM-K2,CCQM-K28,CCQM-K31,CCQM-K25,CCQM-K25,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K29,CCQM-K29,CCQM-K17,CCQM−K9

のようなカンマで区切られた文字列群の集合体であった場合の文字列分解コードはどのようになるのでしょうか?たびたびの質問で申し訳けありませんが、ぜひお教え頂ければ幸いです。

【14612】Re:セルの文字列データの種類分けVBAコー...
発言  ichinose  - 04/6/3(木) 8:12 -

引用なし
パスワード
   ▼しん さん:
おはようございます。

今朝は大変感激してあらゆるデータ例を試してみなかったので気付かなかったのですが、もし題意の文字列が
>
>A02A02B12B13C22C22C23C2A02B13D345A02E99C2
>
>のような場合には、解答が
>
>A02    4
>B12    1
>B13    2
>C22    2
>C23    1
>C2    5
>D345    1
>E99    1

うっ、本当ですね!!
気がつきませんでした・・・。
いくつか試しましたが、結局数えるにことにしました。
以下のように変更・追加して下さい。

'==============================================================
Sub test()
  Dim co As Collection
  Dim ans()
  Call 文字列分解(Range("e1").Value, ans())
  Set co = mk_unique_collection(ans()) '重複なしの集合体の作成
  For idx = 1 To co.Count
   cnt = get_abs_count(ans(), co.Item(idx)) '個数の計算ではなく、数える
   '変更箇所
   Cells(idx, 1).Value = co.Item(idx)
   Cells(idx, 2).Value = cnt
   Next
  Set co = Nothing
End Sub
'↓追加
'=====================================================================
Function get_abs_count(myarray(), pat)
  get_abs_count = 0
  For idx = LBound(myarray) To UBound(myarray)
   If myarray(idx) = pat Then get_abs_count = get_abs_count + 1
   Next idx
End Function

前回のサブプロシジャーはそのまま生きていますからね!!


それから、↓ですが・・・
>
>また、もし、題意の文字列が
>
>CCQM-K13,CCQM-K13,CCQM-K2,CCQM-K28,CCQM-K31,CCQM-K25,CCQM-K25,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K29,CCQM-K29,CCQM-K17,CCQM−K9
>
>のようなカンマで区切られた文字列群の集合体であった場合の文字列分解コードはどのようになるのでしょうか?たびたびの質問で申し訳けありませんが、ぜひお教え頂ければ幸いです。

区切りがはっきりしている分、こっちのほうが分解自体は簡単そうですが・・。

ところで、↑のパターン文字列と前回のパターンと同じプロシジャーで
解析したいと言う事ですか?
そうなると大きく変更しなければなりませんが、

別々の解析プロシジャーだと思ってよろしいですか?


どっちにしても本日、一日、外回りなので、投稿は、夜になってしまいます。

【14641】Re:セルの文字列データの種類分けVBAコー...
発言  ichinose  - 04/6/3(木) 18:41 -

引用なし
パスワード
   ▼しん さん:
こんにちは。
いくつか訂正もかねて全部掲載します。

まず、

>A02A02B12B13C22C22C23C2A02B13D345A02E99C2
↑こっちの文字列の方です。
'============================================================
Sub test()
  Dim co As Collection
  Dim ans() As String
 
  Call 文字列分解(Range("e1").Value, ans())
  Set co = mk_unique_collection(ans()) '重複なしの集合体の作成
  For idx = 1 To co.Count
   cnt = get_abs_count(ans(), co.Item(idx)) '個数の計算ではなく、数える
   Cells(idx, 1).Value = co.Item(idx)
   Cells(idx, 2).Value = cnt
   Next
  Set co = Nothing
End Sub
'====================================================================
Sub 文字列分解(strng, a_array() As String)
  Dim regEx, Match, Matches  ' 変数を作成します。
 
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = "[A-Za-z][0-9]*"
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  idx = 1
  For Each Match In Matches  ' Matches コレクションに対して繰り返し処理を行います。
   ReDim Preserve a_array(1 To idx)
   a_array(idx) = Match.Value
   idx = idx + 1
  Next
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
End Sub
'==============================================================
Function mk_unique_collection(myarray() As String)
  Dim myclct As New Collection
  On Error Resume Next
  For idx = LBound(myarray()) To UBound(myarray())
   myclct.Add myarray(idx), myarray(idx)
   Next
  Set mk_unique_collection = myclct
  Set myclct = Nothing
  On Error GoTo 0
End Function
'===============================================================
Function get_abs_count(myarray() As String, pat As String)
  get_abs_count = 0
  For idx = LBound(myarray) To UBound(myarray)
   If myarray(idx) = pat Then get_abs_count = get_abs_count + 1
   Next idx
End Function

ほとんど変更はありませんが、変数の型宣言をちゃんと記述しました。
実は、そうしないと次のカンマ区切りの文字列を解析しようすると
プロシジャーの共有ができない・・・、何のために分割してるか
わからなくなってしまうので・・・・。

次に
>CCQM-K13,CCQM-K13,CCQM-K2,CCQM-K28,CCQM-K31,CCQM-K25,CCQM-K25,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K8,CCQM-K29,CCQM-K29,CCQM-K17,CCQM−K9
のようなカンマ区切りの文字列のコードです。

'====================================================================
Sub test2()
  Dim co As Collection
  Dim ans() As String
  ans() = Split(Range("e1").Value, ",") 'これはVBAの関数
  Set co = mk_unique_collection(ans()) '重複なしの集合体の作成
  For idx = 1 To co.Count
   cnt = get_abs_count(ans(), co.Item(idx)) '個数の計算ではなく、数える
   Cells(idx, 1).Value = co.Item(idx)
   Cells(idx, 2).Value = cnt
   Next
  Set co = Nothing
End Sub

testと同様にセルE1に解析文字列を入れて実行してみて下さい。

又、問題があったら教えて下さいね!!

【14669】Re:セルの文字列データの種類分けVBAコー...
お礼  しん  - 04/6/4(金) 0:45 -

引用なし
パスワード
   ▼ichinose さん:
こんばんは、もう感激感動ものです。
両方のプロシジャの関数が共通で使えるので私のデータベース構築プログラムの中に両方とも一緒に取り込むことができ、ようやく懸案のデータベース構築が一応完成しました。ichinoseさんのご親切には適切なお礼の言葉も見いだせないくらい感謝しております。ほんとうにありがとうございました。

>又、問題があったら教えて下さいね!!
につきましては、いまのところ問題なく動いておりますが、もし何か予期せぬトラブルが生じましたらまたお知らせさせて頂きます。

とあるwebサイトの質問箱に

A      B
1行燈    芥川10,鴎外157
2囲炉裏   独歩31,谷崎55
3囲炉裏   独歩96
4鵜飼い鴎外26
5お社鴎外17

というテーブルがあって、これを

A      B
1行燈    芥川10,鴎外157
2囲炉裏   独歩31,96,谷崎55
3鵜飼い鴎外26
4お社鴎外17

のように並び替えしたいという質問がありましたが、これなどもichinoseさんの魔術にかかれば簡単に解決できるのでしょうね!

【14689】Re:セルの文字列データの種類分けVBAコー...
発言  ichinose  - 04/6/4(金) 18:21 -

引用なし
パスワード
   ▼しん さん:
こんばんは。

>とあるwebサイトの質問箱に
>
>A      B
>1行燈    芥川10,鴎外157
>2囲炉裏   独歩31,谷崎55
>3囲炉裏   独歩96
>4鵜飼い鴎外26
>5お社鴎外17
>
>というテーブルがあって、これを
>
>A      B
>1行燈    芥川10,鴎外157
>2囲炉裏   独歩31,96,谷崎55
>3鵜飼い鴎外26
>4お社鴎外17
>
>のように並び替えしたいという質問がありましたが、これなどもichinoseさんの魔術にかかれば簡単に解決できるのでしょうね!
簡単ではありませんよ!!
ただ、文字列解析と言うのは、最終的には一文字ずつチェックしていけば
何とかなりそうですよね?

上記の問題は、「おまけ」みたいなもののようですから、
一部だけ・・・。

この問題の入力データの2行目、3行目の「囲炉裏」のB列

「独歩31,谷崎55,独歩96」とまとめるのはガチャガチャ(←表現難しい?)
すれば何とかなりそうですよね・・・。


では、ここから、-----「独歩31,96,谷崎55」に加工するとこだけ。
これだったら、ここで投稿したプロシジャーを使えば何とかなるもので・・。
'====================================================================
Sub test()
  Dim ans() As String
  Dim sep1() As String
  Dim sep2() As String
  Dim ques_str As String
  Dim moto_array() As String
  Dim s_clct As Collection
  ques_str = "独歩31,谷崎55,独歩96,独歩100,谷崎98" '入力データ
  Call 文字列分解(ques_str, sep1(), "[0-9]+") '半角数字を取り出す
  no_num = ques_str
  For idx = LBound(sep1()) To UBound(sep1())
   no_num = replace(no_num, sep1(idx), "") '数字のない文字列作成
   Next
  moto_array() = Split(ques_str, ",") '元データをカンマ分割
  sep2() = Split(no_num, ",") '数字のないデータをカンマ分割
  Set s_clct = mk_unique_collection(sep2()) '重複なし作成
  kdx = 0
  For idx = 1 To s_clct.Count
   wk = Filter(moto_array(), s_clct.Item(idx))
   For jdx = LBound(wk) To UBound(wk)
     ReDim Preserve ans(1 To kdx + 1)
     If jdx = LBound(wk) Then
      ans(kdx + 1) = wk(jdx)
     Else
      ans(kdx + 1) = replace(wk(jdx), s_clct.Item(idx), "")
      End If
     kdx = kdx + 1
     Next jdx
   Next idx
  If kdx > 0 Then
   MsgBox Join(ans(), ",") '出力データ表示
   End If
End Sub
'=================================================================
Sub 文字列分解(strng, a_array() As String, pat As String)
'文字列分解というプロシジャーをちょっと拡張しました
'(というより、私の元コレクションはこっち)

  Dim regEx, Match, Matches  ' 変数を作成します。
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = pat
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  idx = 1
  For Each Match In Matches  ' Matches コレクションに対して繰り返し処理を行います。
   ReDim Preserve a_array(1 To idx)
   a_array(idx) = Match.Value
   idx = idx + 1
  Next
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
End Sub
'=================================================================
Function mk_unique_collection(myarray() As String)
  Dim myclct As New Collection
  On Error Resume Next
  For idx = LBound(myarray()) To UBound(myarray())
   myclct.Add myarray(idx), myarray(idx)
   Next
  Set mk_unique_collection = myclct
  Set myclct = Nothing
  On Error GoTo 0
End Function

簡単なデータならOKだと思います。
Filter関数を使ってますから、また、漏れが心配だけど、
ダメならひとつづつチェックするしかないでしょうね!!

前半は、しんさん 考えてみて下さい。

【14695】Re:セルの文字列データの種類分けVBAコー...
回答  しん  - 04/6/5(土) 2:52 -

引用なし
パスワード
   ▼ichinose さん:
こんばんは、しんです。

さっそくおまけのVBAコードまで教えて頂きありがとうございました。
さすがichinoseさんは相変わらず凄いですね。

ところで
>前半は、しんさん 考えてみて下さい。
ということなので、あちこち重複データ処理法を参考にして、ichinoseさんのコードとドッキングした結果、下記コード

'Option Explicit
Public i, j, k, NumberOfData
'====================================================================
Sub test()
  Dim ans() As String
  Dim sep1() As String
  Dim sep2() As String
  Dim ques_str As String
  Dim moto_array() As String
  Dim s_clct As Collection
 
  Call DeleteDuplicates(NumberOfData)
 
  'ques_str = "独歩31,谷崎55,独歩96,独歩100,谷崎98" '入力データ
 
 For k = 1 To NumberOfData
 
  ques_str = Cells(k, 2).Value
 
  Call 文字列分解(ques_str, sep1(), "[0-9]+") '半角数字を取り出す
  no_num = ques_str
  For idx = LBound(sep1()) To UBound(sep1())
   no_num = Replace(no_num, sep1(idx), "") '数字のない文字列作成
   Next
  moto_array() = Split(ques_str, ",") '元データをカンマ分割
  sep2() = Split(no_num, ",") '数字のないデータをカンマ分割
  Set s_clct = mk_unique_collection(sep2()) '重複なし作成
  kdx = 0
  For idx = 1 To s_clct.Count
   wk = Filter(moto_array(), s_clct.Item(idx))
   For jdx = LBound(wk) To UBound(wk)
     ReDim Preserve ans(1 To kdx + 1)
     If jdx = LBound(wk) Then
      ans(kdx + 1) = wk(jdx)
     Else
      ans(kdx + 1) = Replace(wk(jdx), s_clct.Item(idx), "")
      End If
     kdx = kdx + 1
     Next jdx
   Next idx
  If kdx > 0 Then
   'MsgBox Join(ans(), ",") '出力データ表示
   Cells(k, 5) = Join(ans(), ",") '出力データ表示
  End If
 
 Next k
End Sub
'=================================================================
Sub 文字列分解(strng, a_array() As String, pat As String)
'文字列分解というプロシジャーをちょっと拡張しました
'(というより、私の元コレクションはこっち)

  Dim regEx, Match, Matches  ' 変数を作成します。
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = pat
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  idx = 1
  For Each Match In Matches  ' Matches コレクションに対して繰り返し処理を行います。
   ReDim Preserve a_array(1 To idx)
   a_array(idx) = Match.Value
   idx = idx + 1
  Next
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
End Sub
'=================================================================
Function mk_unique_collection(myarray() As String)
  Dim myclct As New Collection
  On Error Resume Next
  For idx = LBound(myarray()) To UBound(myarray())
   myclct.Add myarray(idx), myarray(idx)
   Next
  Set mk_unique_collection = myclct
  Set myclct = Nothing
  On Error GoTo 0
End Function
'=========重複行の削除と文字列の結合=================================
Sub DeleteDuplicates(NumberOfData)
  Sheets("Sheet1").Activate
  NumberOfData = Application.CountA(ActiveSheet.Range("A:A"))
  For j = 1 To 6
    i = 2
    Do While i <= NumberOfData
      If Cells(i, 1) = Cells(i - 1, 1) Then
        Rows(i).Select
        Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & "," & Cells(i, 2).Value
        Selection.Delete Shift:=xlUp
        NumberOfData = NumberOfData - 1
      End If
      i = i + 1
    Loop
  Next
End Sub

により、題意のデータ列

A    B
行燈    芥川10,鴎外157
囲炉裏    独歩31,谷崎55
囲炉裏    独歩100
囲炉裏    独歩96
鵜飼い    鴎外26
お社    鴎外17,谷崎51

は、次のように変換することができました。題意のデータ列はA列であらかじめソートしておく必要はありますが・・・。

A    B                E
行燈    芥川10,鴎外157          芥川10,鴎外157        
囲炉裏    独歩31,谷崎55,独歩100,独歩96   独歩31,100,96,谷崎55        
鵜飼い    鴎外26              鴎外26        
お社    鴎外17,谷崎51          鴎外17,谷崎51

ichinoseさんのおかげで大変勉強になりました。これからもこれに懲りずまたいろいろ教えて頂けることを祈っております。どうかよろしくお願い致します。

【14698】Re:セルの文字列データの種類分けVBAコー...
回答  しん  - 04/6/5(土) 12:07 -

引用なし
パスワード
   ▼ichinose さん:
こんにちは、しんです。
昨夜投稿したVBAコードをさらに書き改めて、空白行削除、ソートルーチンを加えることにより

A    B
行燈    芥川10,鴎外157    
囲炉裏    独歩31,谷崎55    
囲炉裏    独歩100    
囲炉裏    独歩96    
鵜飼い    鴎外26    
お社    鴎外17,谷崎51    


行燈    芥川10,鴎外157    
囲炉裏    独歩31,谷崎55    

囲炉裏    独歩96    
鵜飼い    鴎外26    
お社    鴎外17,谷崎51    
行燈    芥川10,鴎外157    
囲炉裏    独歩31,谷崎55    


鵜飼い    鴎外26
お社    鴎外17,谷崎51

行燈    芥川10,鴎外157
囲炉裏    独歩31,谷崎55
囲炉裏    独歩100
囲炉裏    独歩96
鵜飼い    鴎外26
お社    鴎外17,谷崎51

のようなデータ列の処理も行えるようにしました。処理結果は

E
鴎外17,17,17,17,谷崎51,51,51,51
独歩31,100,96,31,96,31,31,100,96,谷崎55,55,55,55
鴎外26,26,26,26
芥川10,10,10,10,鴎外157,157,157,157

のようになります。この新しいVBAコードは下記の通りです。


'Option Explicit
Public i, j, k, NumberOfData
Dim myLastRow As Long  '最終行を格納する変数
Dim myLastCol As Integer '最終列を格納する変数

'====================================================================
Sub test()
  Dim ans() As String
  Dim sep1() As String
  Dim sep2() As String
  Dim ques_str As String
  Dim moto_array() As String
  Dim s_clct As Collection
 
 
  Call DelEmptyRow
  Call RowColumn(myLastRow, myLastCol)
  Call SortRange(myLastRow, myLastCol)
  Call DeleteDuplicates(NumberOfData)
  
  'ques_str = "独歩31,谷崎55,独歩96,独歩100,谷崎98" '入力データ
 
For k = 1 To NumberOfData
 
  ques_str = Cells(k, 2).Value
  Call 文字列分解(ques_str, sep1(), "[0-9]+") '半角数字を取り出す
  no_num = ques_str
  For idx = LBound(sep1()) To UBound(sep1())
   no_num = Replace(no_num, sep1(idx), "") '数字のない文字列作成
   Next
  moto_array() = Split(ques_str, ",") '元データをカンマ分割
  sep2() = Split(no_num, ",") '数字のないデータをカンマ分割
  Set s_clct = mk_unique_collection(sep2()) '重複なし作成
  kdx = 0
  For idx = 1 To s_clct.Count
   wk = Filter(moto_array(), s_clct.Item(idx))
   For jdx = LBound(wk) To UBound(wk)
     ReDim Preserve ans(1 To kdx + 1)
     If jdx = LBound(wk) Then
      ans(kdx + 1) = wk(jdx)
     Else
      ans(kdx + 1) = Replace(wk(jdx), s_clct.Item(idx), "")
      End If
     kdx = kdx + 1
     Next jdx
   Next idx
  If kdx > 0 Then
   'MsgBox Join(ans(), ",") '出力データ表示
   Cells(k, 5) = Join(ans(), ",") '出力データ表示
  End If
Next k
End Sub
'=================================================================
Sub 文字列分解(strng, a_array() As String, pat As String)
'文字列分解というプロシジャーをちょっと拡張しました
'(というより、私の元コレクションはこっち)

  Dim regEx, Match, Matches  ' 変数を作成します。
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = pat
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  idx = 1
  For Each Match In Matches  ' Matches コレクションに対して繰り返し処理を行います。
   ReDim Preserve a_array(1 To idx)
   a_array(idx) = Match.Value
   idx = idx + 1
  Next
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
End Sub
'=================================================================
Function mk_unique_collection(myarray() As String)
  Dim myclct As New Collection
  On Error Resume Next
  For idx = LBound(myarray()) To UBound(myarray())
   myclct.Add myarray(idx), myarray(idx)
   Next
  Set mk_unique_collection = myclct
  Set myclct = Nothing
  On Error GoTo 0
End Function
'=========重複行の削除と文字列の結合=================================
Sub DeleteDuplicates(NumberOfData)
  Sheets("Sheet1").Activate
  NumberOfData = Application.CountA(ActiveSheet.Range("A:A"))
  For j = 1 To 6
    i = 2
    Do While i <= NumberOfData
      If Cells(i, 1) = Cells(i - 1, 1) Then
        Rows(i).Select
        Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & "," & Cells(i, 2).Value
        Selection.Delete Shift:=xlUp
        NumberOfData = NumberOfData - 1
      End If
      i = i + 1
    Loop
  Next
End Sub
'==========ソート==================================================
Sub SortRange(myLastRow, myLastCol)
  Worksheets("Sheet1").Range("A1:B" & Format(myLastRow)).Sort _
    Key1:=Worksheets("Sheet1").Columns("A"), _
    Header:=xlGuess
End Sub
'==========最終行、最終列の把握====================================
Sub RowColumn(myLastRow, myLastCol)
  'Dim myLastRow As Long  '最終行を格納する変数
  'Dim myLastCol As Integer '最終列を格納する変数
  With ActiveSheet.UsedRange  '対象はアクティブシートの使用中のセル
   '最終行の行番号
   myLastRow = .Rows(.Rows.Count).Row
   '最終列の列番号
   myLastCol = .Columns(.Columns.Count).Column
  End With
  'MsgBox "使用済みセル範囲の" & Chr(13) & _
  '  "最終行は" & myLastRow & Chr(13) & _
  '  "最終列は" & myLastCol
End Sub
'==========空白行削除===============================================
Sub DelEmptyRow()
  Dim us As Range
  Dim rn As Long
  
  Set us = ActiveSheet.UsedRange  '範囲指定
  For rn = us.Rows.Count To 1 Step -1
    Call ProcessEachRow(Rows(rn))
  Next rn
End Sub
Sub ProcessEachRow(rs As Range)
  Dim DataCount As Integer
  
  DataCount = Application.CountA(rs)
  If DataCount = 0 Then rs.Delete
End Sub

11692 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free