| |
おはようございます。
>重複した数字がある行を判別してグループにし、
>結果をN列に表示したいのですが。
>お力をお貸しいただけないでしょうか？
>
>結果的には、下の例のように、G5：K10までの範囲にある数字を
>以下のようにN列に表示したいのです。
>
>>> G H I J K ... M N
>>> 5 1 1,2,3,4
>>> 6 2 3 1,2,3,4
>>> 7 5 5,6
>>> 8 3 4 1,2,3,4
>>> 9 1 2 1,2,3,4
>>>10 5 6 5,6
アクティブシートのセルＧ５からセルＫn（nは、不定数）とします。
又、G,H,I,J,K列にある数字１行内では、整列されているものとします。
Ｇ Ｈ Ｉ Ｊ Ｋ
1 5 6 7
と整列されていることが条件です
Ｇ Ｈ Ｉ Ｊ Ｋ
1 5 7 6
↑このようになっていない 、ということです。
標準モジュールに
'================================================================
Option Explicit
Sub main()
Dim rng As Range
Dim g0 As Long
Dim tmpsht As Worksheet
Dim myarray As Variant
With ActiveSheet
Set rng = .Range("g5", .Cells(.Rows.Count, "g").End(xlUp)).Resize(, 5)
If rng.Row >= 5 Then
Set tmpsht = Workbooks.Add.Worksheets(1)
rng.Copy tmpsht.Range("a1")
With tmpsht
With .Range("a1:e" & rng.Rows.Count)
.Sort Key1:=.Range("C1"), Order1:=xlAscending, Key2:=.Range("D1") _
, Order2:=xlAscending, Key3:=.Range("E1"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal, DataOption3:=xlSortNormal
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal
Call dics_init
For g0 = 1 To .Rows.Count
If .Range("a" & g0, tmpsht.Cells(g0, tmpsht.Columns.Count).End(xlToLeft)).Count = 1 Then
myarray = Array(.Range("a" & g0, tmpsht.Cells(g0, tmpsht.Columns.Count).End(xlToLeft)).Value)
Else
myarray = .Range("a" & g0, tmpsht.Cells(g0, tmpsht.Columns.Count).End(xlToLeft)).Value
myarray = Application.Transpose(Application.Transpose(myarray))
End If
Call dics_put_value(myarray)
Next
End With
End With
tmpsht.Parent.Close False
With rng
For g0 = 1 To rng.Rows.Count
myarray = dics_get_array(rng.Cells(g0, 1).Value)
.Cells(g0, 8).Value = Join(myarray, ",")
Next
End With
Call dics_term
End If
End With
End Sub
別の標準モジュールに
'=================================================================
Option Explicit
Private dic() As Object
Private dicnum As Long
'=================================================================
Sub dics_init()
dicnum = 0
End Sub
'=================================================================
Function dics_get_array(myvalue As Variant) As Variant
Dim g0 As Long
dics_get_array = False
For g0 = 1 To dicnum
If dic(g0).Exists(myvalue) Then
dics_get_array = dic(g0).Keys
Exit For
End If
Next
End Function
'=================================================================
Sub dics_put_value(myarray As Variant)
Dim g0 As Long
Dim g1 As Long
Dim ret As Long
ret = 0
For g0 = 1 To dicnum
For g1 = LBound(myarray) To UBound(myarray)
If dic(g0).Exists(myarray(g1)) Then
ret = g0
Exit For
End If
Next
If ret <> 0 Then Exit For
Next
If ret = 0 Then
ReDim Preserve dic(1 To dicnum + 1)
ret = dicnum + 1
dicnum = dicnum + 1
Set dic(ret) = CreateObject("scripting.dictionary")
End If
For g1 = LBound(myarray) To UBound(myarray)
dic(ret)(myarray(g1)) = myarray(g1)
Next
End Sub
'=================================================================
Sub dics_term()
Dim g0 As Long
For g0 = 1 To dicnum
Set dic(g0) = Nothing
Next
Erase dic()
End Sub
として、当該シートをアクティブにして、mainを実行してみてください。
|
|
ichinose
- 08/12/1(月) 8:46 -
