Sub FindDuplicate()
Dim i As Long, j As Long, k As Long
Dim rng1 As Range, rng2 As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") '指定操作的工作表
For i = 5 To 20 Step 4 '循環遍歷每4行數據
Set rng1 = ws.Range("A" & i & ":O" & i) '獲取當前行的數據範圍
For j = i + 1 To i + 3 '循環遍歷當前行的下壹行到下三行
Set rng2 = ws.Range("A" & j & ":O" & j) '獲取下壹行到下三行的數據範圍
For k = 17 To 1 Step -1 '從O列開始往前遍歷
If rng1.Cells(1, k) = rng2.Cells(1, k) Then '判斷是否有重復數字
ws.Range("Q" & i) = rng1.Cells(1, k) '將重復數字放在Q:Z列
ws.Range("R" & i) = rng1.Cells(1, k)
ws.Range("S" & i) = rng1.Cells(1, k)
ws.Range("T" & i) = rng1.Cells(1, k)
ws.Range("U" & i) = rng1.Cells(1, k)
ws.Range("V" & i) = rng1.Cells(1, k)
ws.Range("W" & i) = rng1.Cells(1, k)
ws.Range("X" & i) = rng1.Cells(1, k)
ws.Range("Y" & i) = rng1.Cells(1, k)
ws.Range("Z" & i) = rng1.Cells(1, k)
Exit For '找到壹個重復數字就退出循環
End If
Next k
Next j
Next i
'將結果在另壹行輸出
For i = 4 To 20 Step 4
Set rng1 = ws.Range("Q" & i & ":Z" & i)
Set rng2 = ws.Range("A" & i & ":O" & i)
For j = 1 To 10
If WorksheetFunction.CountIf(rng1, rng2.Cells(1, j)) > 1 Then
ws.Cells(22, j) = rng2.Cells(1, j)
End If
Next j
Next i
End Sub
這個代碼首先使用循環遍歷每四行數據，對於每壹行，再使用循環遍歷當前行的下壹行到下三行，判斷是否有重復數字。如果有重復數字，就將這些數字放在Q:Z列。最後，再遍歷每四行數據的結果，統計出重復的數字，並將結果在第22行輸出。