| |
▼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
|
|
しん
- 04/6/5(土) 12:07 -
