Excel VBA質問箱 IV

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

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


22937 / 76732 ←次へ | 前へ→

【59167】Re:グループ分けをしたいのですが
発言  ichinose  - 08/12/1(月) 8:46 -

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


>重複した数字がある行を判別してグループにし、
>結果を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 


アクティブシートのセルG5からセルKn(nは、不定数)とします。
又、G,H,I,J,K列にある数字1行内では、整列されているものとします。

 G  H  I  J  K
  1  5   6   7

と整列されていることが条件です

 G  H  I  J  K
  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を実行してみてください。
1 hits

【59162】グループ分けをしたいのですが smasa 08/11/30(日) 23:35 質問
【59163】Re:グループ分けをしたいのですが かみちゃん 08/11/30(日) 23:38 発言
【59167】Re:グループ分けをしたいのですが ichinose 08/12/1(月) 8:46 発言
【59186】Re:グループ分けをしたいのですが smasa 08/12/1(月) 20:02 お礼
【59177】Re:グループ分けをしたいのですが Yuki 08/12/1(月) 13:42 発言

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