Excel VBA エクセル マクロ リスト上 条件一致 コピペ 繰り返す

エクセルVBAに詳しい方、ご教示願い致します。
当方VBA初心者でして、色々検索して自分なりにやってみているのですが、思い通りの処理とならず、ご教授いただけると幸いです。
Sheet1にリストがあります。
このリストの項目のうち、同じ部署内での2人の組み合わせパターンを全てSheet2へリストアップするというものです。
条件は部署が一緒であることのみで、部署によって人数が異なるので、対象者1名に対する組み合わせ個数は同部署人数-1、となります。ただ、対象者本人に対し組み合わせリストに本人が入ってしまっていても、VBA処理後に、手作業でA列とD列の重複削除を行えますので、問題ないのですが、人数と部署が多く、条件に一致する繰り返しのコピペを一致する数の分だけリストの上から下までループ処理したく、ご助力頂きますよう、何卒宜しくお願い致します。

No.3 回答者： Qchan1962 回答日時： 2022/01/17 23:24

#2です

ごめんなさい。全く違う事を書いてしまいました。忘れてください。

No.2 回答者： Qchan1962 回答日時： 2022/01/17 23:18

こんばんは、

べたに考えてみました
Sub test()
Dim i As Long, n As Long, j As Long
Dim ary()
Dim lastRow As Long
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim ary(WorksheetFunction.Permut(lastRow, 2) / 2, 6)
j = 2
Do While .Cells(j, 1) <> ""
For i = j To lastRow - 1
If .Cells(j, 1) <> Cells(i + 1, 1) Then
ary(n, 0) = .Cells(j, 1)
ary(n, 1) = .Cells(j, 2)
ary(n, 2) = .Cells(j, 3)
ary(n, 3) = .Cells(i + 1, 1)
ary(n, 4) = .Cells(i + 1, 2)
ary(n, 5) = .Cells(i + 1, 3)
n = n + 1
End If
Next
j = j + 1
Loop
End With
Worksheets("Sheet2").Cells(2, 1).Resize(UBound(ary, 1), UBound(ary, 2)) = ary
End Sub

No.1 回答者： fujillin 回答日時： 2022/01/17 22:54

こんばんは

1行目はタイトル行で2行目からデータがあり、リストには重複はないものと仮定します。
人数が1人の部署がある場合、組み合わせは作成されません。
ご提示のリストは部署別に順に記載されているようですが、念のためマクロでもソートし直します。
（これにより、作成される部署の順序は変わる可能性があります。）

以下ではいかがでしょうか？

Sub Q12762938()
Dim sh As Worksheet, r As Range, v
Dim n As Long, i As Long, j As Long
Dim n1 As Long, n2 As Long

Set sh = Worksheets("Sheet1")
n = sh.Cells(Rows.Count, 1).End(xlUp).Row - 1

With Worksheets("Sheet2")
.Cells.ClearContents
If n < 1 Then Exit Sub

Set r = .Range("A1:C1").Resize(n + 1)
r.Value = sh.Range("A1:C1").Resize(n + 1).Value
r.Sort key1:=.Cells(1, 2), Header:=xlYes
Set r = .Range("A2:C2")
v = r.Resize(n).Value
r.Resize(n).ClearContents
n1 = 1

While n1 < n
n2 = n
For i = n1 To n2 - 1
If v(i + 1, 2) <> v(n1, 2) Then n2 = i: Exit For
Next i

For i = n1 To n2 - 1
For j = i + 1 To n2
r.Value = Array(v(i, 1), v(i, 2), v(i, 3))
r.Offset(, 3).Value = Array(v(j, 1), v(j, 2), v(j, 3))
Set r = r.Offset(1)
Next j
Next i
n1 = n2 + 1
Wend

End With
End Sub