Excel VBA質問箱 IV

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

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


3971 / 13646 ツリー ←次へ | 前へ→

【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 発言[未読]

【59162】グループ分けをしたいのですが
質問  smasa  - 08/11/30(日) 23:35 -

引用なし
パスワード
   よろしくお願いします。

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

行方向は空白セルでとまるようにします。(例の場合は10まで)

もともとは下のように数字が入力されています。
(1番左は行番号です)

          列
>>    G H I J K ... M N
>> 5    1        
>> 6    2 3       
>> 7    5        
>> 8    3 4       
>> 9   1 2       
>>10   5 6      

G5の1から、表の上から順番に、範囲内(G5:K10)に同じ数字がないかどうか調べます。
たとえば、G5の1という数字はG9にも入力されています。
ですから、行5と行9は同じグループ。
次に、G6の2という数字はH9にも入力されていますので、
行5と行9と行6は同じグループ。
次に、H6の3という数字はG8にもあります。
行5、行9、行6、行8は同じグループ。
次にH8の4は他に入力されていません。
そこで、各グループの数字を取り出し、重複しないように
N列に以下のように入力されるようにします。

          列
>>   F  G H I J K ... M N
>> 5  12  1          1,2,3,4
>> 6  21  2 3         1,2,3,4
>> 7  30  5        
>> 8  11  3 4         1,2,3,4
>> 9  6  1 2         1,2,3,4
>>10  2  5 6

次にG7の5という数字はG10にもあります。
ですので、行7と行10は同じグループで、
N列の7と10には5,6と入力されるようにしたいのです。

関数等を使ってやってみていますが、
なかなかうまくいきません。
お考えをいただきたく、よろしくお願いいたします。

【59163】Re:グループ分けをしたいのですが
発言  かみちゃん E-MAIL  - 08/11/30(日) 23:38 -

引用なし
パスワード
   こんにちは。かみちゃん です。

#回答ではありません。

>お考えをいただきたく

よく見ていませんが、[59161]のご質問と何か違うのでしょうか?
新しくスレッドを立てたならば、[59161]の返信でその旨を知らせていただいた
ほうがよろしいかと思います。

【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を実行してみてください。

【59177】Re:グループ分けをしたいのですが
発言  Yuki  - 08/12/1(月) 13:42 -

引用なし
パスワード
   ▼smasa さん:
>
>重複した数字がある行を判別してグループにし、
>結果を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 
>>>11
>
>行方向は空白セルでとまるようにします。(例の場合は10まで)
>
>もともとは下のように数字が入力されています。
>(1番左は行番号です)
>
>          列
>>>    G H I J K ... M N
>>> 5    1        
>>> 6    2 3       
>>> 7    5        
>>> 8    3 4       
>>> 9   1 2       
>>>10   5 6      
>
上記のデータだとして
こんな感じですか?
Option Explicit

Sub Macro1()
  Dim eRow  As Long
  Dim v  As Variant
  Dim i  As Long
  Dim j  As Long
  Dim x  As Long
  Dim A() As Variant
  Dim rng As Range
  Dim D  As Variant
  
  eRow = Range("G" & Rows.Count).End(xlUp).Row
  Set rng = Range("N1:N" & eRow)
  rng.Cells(1) = 1
  rng.DataSeries xlColumns
  Set rng = Nothing
  
  Set rng = Range("G1:N" & eRow)
  rng.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
       SortMethod:=xlPinYin, DataOption1:=xlSortNormal
      
  v = Range("G2:K" & eRow).Value
  
  rng.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
       SortMethod:=xlPinYin, DataOption1:=xlSortNormal
  
  Columns(14).ClearContents
  
  For i = 1 To UBound(v)
    If v(i, 2) = Empty Then
      x = x + 1
      ReDim Preserve A(1 To x)
      A(x) = v(i, 1)
    Else
      For j = 1 To UBound(v, 2)
        If v(i, j) = Empty Then Exit For
        ' 連番の時の処理
        If v(i, j) = Split(A(x), ",")(UBound(Split(A(x), ","))) + 1 Then
          A(x) = A(x) & "," & v(i, j)
        Else
'          ' 連番で無い時のは何でもグループにいれてしまう?
'          A(x) = A(x) & "," & v(i, j)
        End If
      Next
    End If
  Next

  v = Range("G2:N" & eRow).Value
  For i = 1 To UBound(v)
    For j = 1 To UBound(A)
      D = Split(A(j), ",")
      For x = 0 To UBound(D)
        If CStr(v(i, 1)) = D(x) Then
          v(i, 8) = A(j)
          Exit For
        End If
      Next
    Next
  Next
  Range("G2").Resize(UBound(v), UBound(v, 2)).Value = v
End Sub

【59186】Re:グループ分けをしたいのですが
お礼  smasa  - 08/12/1(月) 20:02 -

引用なし
パスワード
   ▼ichinose さん:
ありがとうございます!
できました!

これを参考に、
また勉強します。
ありがとうございました!

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