Excel VBA質問箱 IV

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

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


66602 / 76734 ←次へ | 前へ→

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

0 hits

【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 回答

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