[[20210605130110]]　『メンバーリスト通りに振り分けを行う』（WE4）　ページの最後に飛ぶ

『メンバーリスト通りに振り分けを行う』（WE4）

1グループ　AさんーGさん
2グループ　HさんーNさん
3グループ　OさんーUさん
4グループ　VさんーZさん

AさんからZさんがいます。この中から2人ずつ適当にピックアップします。
グループの数が小さい方が左、大きい方が右になるようにシート全体の並び替えを行いたいです。（同じグループの方が選択された場合はどちらでも構いません。）

例）
Qさん　Nさん⇒Nさん　Qさん
Bさん　Fさん⇒Bさん　Fさん
Hさん　Oさん⇒Hさん　Oさん

＜使用 Excel：Excel2016、使用 OS：Windows7 ＞

 これは関数でしょうか？
ちょっと関数はわからないのでVbaになっちゃいました。。。
こう↓あったときにJK列のデータをMN列に表示します。

 こんばんは！
そうですよねぇ。。無視されるより全然ましなんで、、どんどん(は、困りますけど、）聞いてください。
でも、私は、、基本的に土日、、平日は夜20時ごろくらいしか見れませんので、、あしからずご了承願います。。。

 データはSheet1のA1を基準に必要数追加してください。

     |[A]       |[B]|[C]|[D]|[E]|[F]|[G]|[H]|[I]|[J]|[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] 
 [1] |1グループ |A  |B  |C  |D  |E  |F  |G  |   |   |    |    |    |    |    |    |    |    |    |    |    |    
 [2] |2グループ |H  |I  |J  |K  |L  |M  |N  |   |   |    |    |    |    |    |    |    |    |    |    |    |    
 [3] |3グループ |O  |P  |Q  |R  |S  |T  |U  |   |   |    |    |    |    |    |    |    |    |    |    |    |    
 [4] |4グループ |V  |W  |X  |Y  |Z  |   |   |   |   |    |    |    |    |    |    |    |    |    |    |    |    
 [5] |5グループ |あ1|あ2|あ3|あ4|あ5|あ6|あ7|あ8|あ9|あ10|あ11|あ12|あ13|あ14|あ15|    |    |    |    |    |    
 [6] |6グループ |ｂ1|ｂ2|ｂ3|ｂ4|ｂ5|ｂ6|ｂ7|ｂ8|ｂ9|ｂ10|ｂ11|ｂ12|ｂ13|ｂ14|ｂ15|ｂ16|ｂ17|ｂ18|    |    |    
 [7] |7グループ |ｃ1|ｃ2|ｃ3|ｃ4|ｃ5|ｃ6|ｃ7|ｃ8|ｃ9|ｃ10|ｃ11|ｃ12|ｃ13|ｃ14|ｃ15|ｃ16|ｃ17|ｃ18|ｃ19|    |    
 [8] |8グループ |ｄ1|ｄ2|ｄ3|ｄ4|ｄ5|ｄ6|ｄ7|ｄ8|ｄ9|ｄ10|ｄ11|ｄ12|ｄ13|ｄ14|ｄ15|ｄ16|ｄ17|ｄ18|ｄ19|    |    
 [9] |9グループ |え1|え2|え3|え4|え5|え6|え7|え8|え9|え10|え11|え12|え13|え14|え15|え16|え17|え18|え19|    |    
 [10]|10グループ|ｆ1|ｆ2|ｆ3|ｆ4|ｆ5|ｆ6|ｆ7|ｆ8|ｆ9|ｆ10|    |    |    |    |    |    |    |    |    |    |    
 [11]|11グループ|ｇ1|ｇ2|ｇ3|ｇ4|ｇ5|ｇ6|ｇ7|ｇ8|ｇ9|ｇ10|ｇ11|ｇ12|ｇ13|    |    |    |    |    |    |    |    
 [12]|12グループ|ｈ1|ｈ2|ｈ3|ｈ4|ｈ5|ｈ6|ｈ7|ｈ8|ｈ9|ｈ10|ｈ11|ｈ12|ｈ13|    |    |    |    |    |    |    |    
 [13]|13グループ|い1|い2|い3|い4|い5|い6|い7|い8|い9|い10|い11|い12|い13|い14|い15|い16|い17|い18|い19|い20|い21
 [14]|14グループ|う1|う2|う3|う4|う5|う6|う7|う8|う9|う10|う11|う12|う13|う14|う15|う16|う17|    |    |    |    
 [15]|15グループ|お1|お2|お3|お4|お5|お6|お7|お8|お9|お10|お11|お12|お13|お14|お15|お16|    |    |    |    |

 抽出したいデータです。
Sheet2のA列B列を想定しています。好きなだけ必要数かいてください。

    |[A] |[B] 
 [1] |Q   |N   
 [2] |B   |F   
 [3] |H   |O   
 [4] |D   |M   
 [5] |R   |J   
 [6] |P   |B   
 [7] |W   |A   
 [8] |Y   |G   
 [9] |R   |C   
 [10]|Z   |U   
 [11]|ｄ7 |ｆ10
 [12]|ｄ13|ｄ7 
 [13]|ｆ7 |え6 
 [14]|ｈ9 |え13
 [15]|う11|あ10

 結果を書き出します。
Sheet3のA列B列を想定しています。ここをSheet2にするとSheet2の内容が書き換わります。

     |[A] |[B] 
 [1] |N   |Q   
 [2] |B   |F   
 [3] |H   |O   
 [4] |D   |M   
 [5] |J   |R   
 [6] |B   |P   
 [7] |A   |W   
 [8] |G   |Y   
 [9] |C   |R   
 [10]|U   |Z   
 [11]|ｄ7 |ｆ10
 [12]|ｄ13|ｄ7 
 [13]|え6 |ｆ7 
 [14]|え13|ｈ9 
 [15]|あ10|う11

 あってますかぁ？？？

 Option Explicit
Sub てすと()
Dim q As Variant
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim v As Variant
Dim i As Long
Dim k As Long
Dim x1 As Long
Dim x2 As Long
'グループの一覧です。
'Sheet1のA1から下に横に好きなだけ追加してください。
q = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim x(UBound(q, 1) - 1)
For i = LBound(x) To UBound(x)
    x(i) = Range("B" & i + 1).Resize(, UBound(q, 2) - 1).Value
Next
'選択するメンバーです。
'Sheet2のA列B列を想定しています。好きなだけ追加してください。
With Sheets("Sheet2")
    y = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
End With
ReDim v(LBound(y, 1) To UBound(y, 1), LBound(y, 2) To UBound(y, 2))
For k = LBound(y, 1) To UBound(y, 1)
    x1 = 0
    x2 = 0
    For i = LBound(x) To UBound(x)
        z = Application.Match(y(k, 1), x(i), 0)
        If Not IsError(z) Then x1 = i + 1
        z = Application.Match(y(k, 2), x(i), 0)
        If Not IsError(z) Then x2 = i + 1
        If x1 * x2 > 0 Then Exit For
    Next
    If x1 > x2 Then
        v(k, 1) = y(k, 2)
        v(k, 2) = y(k, 1)
    Else
        v(k, 1) = y(k, 1)
        v(k, 2) = y(k, 2)
    End If
Next
'結果を書き出す場所です。
'Sheet3のA列B列を想定しています。
'ここをSheet2にするとSheet2の内容が結果的に書き換わります。
With Sheets("Sheet3")
    .Range("A:B").Clear
    .Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End With
Erase q, x, y, v
End Sub
（SoulMan） 2021/06/05(土) 16:01

回りくどい質問をしてしまいまして申し訳ございません。
A-Zを人名前でやりたいと考えております。
どこをどのように編集したらできますでしょうか？
また、グループの人数も数えきれないほどなので結果を表示させる位置も変えたいと考えている場合の編集の仕方も教えていただけると助かります。

（WE4） 2021/06/06(日) 18:53

 上のコードを可変に書き換えておきましたのでお試しください。。。
私の回答はわかりずらいのか無視されて不評なんですよねぇ(^^;

 結構、、堪えるんで。。。まぁ、、仕方ないんですけどね＿|￣|○
（SoulMan） 2021/06/06(日) 19:49

A-Zを人名前でやりたいと考えております。

全く検証していませんが、
　Sheet1のB列から右へグループ毎に属する人名（名前）を書き出せば良いと思います。
　グループが増えれば必要数下方向にグループ毎に人名を書き出す。

　Sheet2のA,B列に「2人ずつ適当にピックアップします。」に相当する人名をピックアップして記入

　 Sub てすと　を実行すると
　Sheet3のA,B列に希望の結果が出力される

結果を表示させる位置も変えたいと考えている場合の編集の仕方も教えていただけると助かります。

  以下のコードが出力部ですが。。。。

   With Sheets("Sheet3")
    .Range("A:B").Clear
    .Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
（白戸） 2021/06/07(月) 11:06

返信ありがとうございます。
とても分かりやすく参考になります。
追加で一つお伺いしたいのですが、
”Sheet2” で２人選択していますが、これを不特定多数の人数選択して並び替えることは可能でしょうか？例を挙げますので解決できたらうれしいです。
もし可能でしたらそのままコピー＆ペーストできる形にしていただけると嬉しいです。
よろしくお願いいたします。

ピックアップ

”Sheet2”
C │F │Z
V │d1│C
g6│K │N8│B
y3│h9│d5│T│A

結果
”Sheet3”
C │F │Z │ │ │
C │d1│V │ │ │
B │K │g6│N8│ │
A │T │d5│h9│y3│

（WE4） 2021/06/10(木) 15:33

 こんばんは！
答え合わせが難しくてあってるかどうか不安ですけど、、、
最初に提示した表を例にすると。。。

 Sheet2に↓
    |[A] |[B]|[C]|[D]|[E] |[F]
 [1]|C   |F  |Z  |   |    |   
 [2]|V   |ｄ1|C  |   |    |   
 [3]|ｇ6 |K  |ｆ8|B  |    |   
 [4]|い4 |A  |ｄ5|T  |ｈ9 |   
 [5]|ｄ1 |   |   |   |    |   
 [6]|お10|ｇ8|ｄ4|う5|あ11|Z

 Sheet3に↓
    |[A]|[B] |[C]|[D]|[E]|[F] 
 [1]|F  |C   |Z  |   |   |    
 [2]|C  |V   |ｄ1|   |   |    
 [3]|B  |K   |ｆ8|ｇ6|   |    
 [4]|A  |T   |ｄ5|ｈ9|い4|    
 [5]|ｄ1|    |   |   |   |    
 [6]|Z  |あ11|ｄ4|ｇ8|う5|お10

 あってますかぁ？？？

 Option Explicit
Sub てすと()
Dim q As Variant
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim v As Variant
Dim w() As Variant
Dim g() As Variant
Dim 重み As Double
Dim グループ As Variant
Dim 色 As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim xi As Long
'グループの一覧です。
'Sheet1のA1から下に横にお好きなだけ追加してください。
With Sheets("Sheet1")
    With .Range("A1")
        q = .CurrentRegion.Value
        ReDim x(UBound(q, 1) - 1)
        For i = LBound(x) To UBound(x)
            x(i) = .Offset(i, 1).Resize(, UBound(q, 2) - 1).Value
        Next
        'グループ1に名前を付けます。不要になったら削除してください。。。
        '*************************************************************
        ReDim グループ(2)
        For i = LBound(グループ) To UBound(グループ)
            グループ(i) = .Offset(i).Value
            .Offset(i, 1).Resize(, UBound(q, 2) - 1).Name = グループ(i)
        Next
        '*************************************************************
    End With
End With
重み = Application.Ceiling(UBound(q, 1) * UBound(q, 2), 1000)
'選択するメンバーです。
'Sheet2のA1から下に横にお好きなだけ追加してください。
y = Sheets("Sheet2").Range("A1").CurrentRegion.Value
ReDim v(LBound(y, 1) To UBound(y, 1), LBound(y, 2) To UBound(y, 2))
ReDim g(LBound(y, 1) To UBound(y, 1) + 1, LBound(q, 1) To UBound(q, 1))
For j = LBound(g, 2) To UBound(g, 2)
    g(1, j) = j & "G"
Next
For i = LBound(y, 1) To UBound(y, 1)
    k = 0
    ReDim w(1 To 2, 1 To 1)
    For j = LBound(y, 2) To UBound(y, 2)
        If y(i, j) <> "" Then
            For xi = LBound(x) To UBound(x)
                z = Application.Match(y(i, j), x(xi), 0)
                If Not IsError(z) Then
                    k = k + 1
                    g(i + 1, xi + 1) = g(i + 1, xi + 1) + 1
                    ReDim Preserve w(1 To 2, 1 To k)
                    w(1, k) = (xi + 1) * 重み + z
                    w(2, k) = y(i, j)
                    Exit For
                End If
            Next
        End If
    Next
    If UBound(w, 2) > 1 Then
        w = Application.Transpose(w)
        QuickSort w, 1, LBound(w, 1), UBound(w, 1)
        For xi = LBound(w, 1) To UBound(w, 1)
            v(i, xi) = w(xi, 2)
        Next
    Else
        v(i, 1) = w(2, 1)
    End If
Next
'結果を書き出す場所です。
'Sheet3のB2を基準に想定しています。
'ここをSheet2にするとSheet2の内容が結果的に書き換わります。
'その場合は、Sheet2もB2にする必要があります。
Application.ScreenUpdating = False
    With Sheets("Sheet3")
        .Cells.FormatConditions.Delete
        If .Range("A1").Value = "" Then .Range("A1").Value = "ダミー"
        With .Range("B2")
            .Resize(, .CurrentRegion.Columns.Count - 1).EntireColumn.ClearContents
            .Resize(UBound(v, 1), UBound(v, 2)).Value = v
            '条件付き書式を設定します。不要になったら削除してください。。。。
            '*****************************************************************************************************************
            色 = Array(vbRed, vbBlue, vbYellow)
            With .Resize(UBound(v, 1), UBound(v, 2))
                For i = LBound(グループ) To UBound(グループ)
                    .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(" & グループ(i) & "," & .Cells(1).Address(0, 0) & ")"
                    .FormatConditions(i + 1).Interior.Color = 色(i)
                    .FormatConditions(i + 1).StopIfTrue = False
                Next
            End With
            '******************************************************************************************************************
            .Offset(-1, UBound(v, 2)).Resize(UBound(g, 1), UBound(g, 2)).Value = g
        End With
        If .Range("A1").Value = "ダミー" Then .Range("A1").Value = ""
    End With
Application.ScreenUpdating = True
Erase q, x, y, v, w, グループ, 色, g
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
    Do
        Do While MySAry(i, MySKey) < MySMid
            i = i + 1
        Loop
        Do While MySAry(j, MySKey) > MySMid
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For n = MySLBound To MySUBound
            MyStmp = MySAry(i, n)
            MySAry(i, n) = MySAry(j, n)
            MySAry(j, n) = MyStmp
        Next
        i = i + 1
        j = j - 1
    Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
グループの中でも順位付けがある方がいいでしょうから「重み」を追加しました。2021/6/11 05:32
条件付き書式を追加しました。2021/06/13　09:54
（SoulMan） 2021/06/10(木) 20:15

順位付けまでしてくださってありがとうございます。
Sheet3のデータで各グループ色付けをしたいと考えています。
条件付き書式で＝COUNTIF(1グループ,A1)で適応範囲をページ全体にしました。
VBAを実行すると適応範囲が=$4:$1048576,$K$1:$XFD$3に変わってしまいます。
なぜかは分からないので何か解決策がありましたらよろしくお願い致します。
また、Sheet3の結果を現在A1から表示しているのですが、B2から表示するにはどのように編集したらよろしいでしょうか？
（WE4） 2021/06/12(土) 18:51

これからも質問を重ねてしまう可能性がありますのでもし可能でしたらZOOM等で画面共有しながら教えて頂くことは可能でしょうか？
時間は何時でも大丈夫です。
（WE4） 2021/06/12(土) 18:57

 書き出しは、、↓でいいと思いますが、、.CurrentRegion.Clear　が悪さをする恐れがありますので、、
レイアウトによって変えないといけませんね。。
With Sheets("Sheet3")
    .Range("B2").CurrentRegion.Clear
    .Range("B2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End With

 条件付き書式のことはわかりませんが、、範囲が変わる要因として数式内のA1がフリーですから
少なくともそのA1をアクティブ、、選択した状態でその条件付き書式を設定しなければいけません。
＝COUNTIF(1グループ,A1)

 また、今回の場合は、配列で処理していますので条件付き書式は関係ないと思いますが、、
ずれるようでしたら処理が完了した後にそのセルを選択した状態で再設定してください。
その際はマクロの記録から応用してみてください。。。

 また、、私は、、最近、調子乗って自分の能力以上に回答してしまっていますが、、
本当は、、週に2～3問程度です。それも比較的簡単のもを選んで回答しています。。。(^^;

 忙しい時は、、学校を覗くことも出来ませんのでご希望には添えないと思います。
私でなくても皆さん教えてくれますから、、そこは心配ありません。m(__)m
（SoulMan） 2021/06/12(土) 19:23

 おはようございます。。。
ちょっと気になったのでSheet3に条件付き書式を設定してみました。

 取り敢えず、、一番上の　1グループ　だけです。
名前を　グループ1　にしないといけないらしく　グループ1　に変更しました。
別にずれませんけどね？？？

 変更ついでに
 書き出し位置を　B2　にして
 .Clear　だと消えちゃうので
 .ClearContents　にして
 ぐらいでしょうか？

 条件付き書式を設定するコードを追加していますので不要になったら削除してください。。。

 なにかの参考になれば幸いです。。。

 では、、では、、、
（SoulMan） 2021/06/13(日) 09:55

ありがとうございます。
B2から表示させるときA行の文字が消えてしまいます。
対策等ありましたらよろしくお願いします。
（WE4） 2021/06/17(木) 09:50

追記
各グループのメンバーは最大で１５人です。
並び変えたSheet3の右側に１グループの人が何人、２グループの人が何人という風に表示させたいです。
宜しくお願いいたします。
（WE4） 2021/06/17(木) 15:30

 こんばんは！
A列には必ず何かがある。。というのと、、
ある時もある。。。とでは、、ちょっと違ってきます。。。

 なので回答する側としては、、どっちでもいいような対策を考えないとけません。
これはブラインドExcelの宿命ですね(^^;

 ところで、私は、、当然、、働いてます。。。朝も結構、、早いです。。。
仕事中は、ほんと目が回るくらい。。。無理難題を押し付けられてそれを何とかこなしてます。
家に帰って、、お風呂に入って、、ご飯を食べて、学校を覗くのが楽しみです。。
後、他にツムツムと競馬、、、最近、、ツムツムやれてないんですよねぇ、、まだ、、今月のイベントが終わってないという非常事態(笑)
で、、大体、、平日に家でExcelにさわれるのは、、どうだろう。。多くて、、2時間～3時間くらい。。。かな？全然、、触れない日も当然あります。。。
おっさん、、そんな個人情報はええから早よ回答せんかい！！、、はいっ、すみません。。。。m(__)m

 何が、、言いたいのかと言いますと、、もうそろそろ、、このトピも終わりにしませんか？？？
嫌じゃないんですよ。。全然、、でも、、まぁ、、この展開になるとだれも読んでないんですよねぇ(^^;
わちきがそう、、、あっ、、ながい・・・パスっ、、ってなるでしょ？
そうなると不利益を得るのは結局トピ主さんなんですよね。。。

 今回のグループごとの人数も見る人が見れば、、いたって単純なコードの追加だけで、、ちょっろと書けちゃうんです。。。
そうすると、、一旦、一区切りして新たに質問された方が早くていい回答を得ることが出来ると思うのです。。。。

 くれぐれも、、ご気分を悪くなされずに、、、頑張ってくださいね。。。
では、、、では、、、また、、は、、ないね(^^;
（SoulMan） 2021/06/17(木) 23:05

コメント返信：

[ 一覧(最新更新順) ]

[[20210605130110]] 『メンバーリスト通りに振り分けを行う』（WE4） ページの最後に飛ぶ

[[20210605130110]]　『メンバーリスト通りに振り分けを行う』（WE4）　ページの最後に飛ぶ