Sub 按鈕1_Click()Dim arr, k1, k2With Worksheets("sheet1") k1 = .[a1].End(4).Row k2 = .[a1].End(2).Column arr = .[a1].Resize(k1, k2)End WithDim d, temp, temp1Set d = CreateObject("Scripting.Dictionary")k = 1""""""""""""""""""""""For i = 2 To k1temp = ""For j = 2 To k2 If arr(i, j) > 0 Then temp = temp & ";" & j & "," & arr(i, j)Next jd(temp) = d(temp) & "|" & arr(i, 1)Next i""""""""""""""""""""""For Each element In d.keys kk = Split(d(element), "|") If UBound(kk) > 1 Then k = k + 1 Cells(k, 1) = element Cells(k, 2) = d(element) End IfNextEnd Sub