jcchiang

¦^´_ 1# ÅÚ½³ªd

¸Õ¸Õ¬Ý
Sub ex()
Dim d As Object
Dim a, b, x%
Set d = CreateObject("Scripting.Dictionary")
For Each b In Range(Sheets("µn¿ý").[B3], Sheets("µn¿ý").[B65536].End(3))
   For x = 0 To b.Offset(, 1) - 1
      With Sheets("¯S¥ð¤Ñ¼Æ")
         For Each a In Range(.[a2], .[a65535].End(3))
            If a = Sheets("µn¿ý").[b1] And a.Offset(, 3) <= b + x And a.Offset(, 4) >= b + x Then                    
               If b.Offset(, 2) = "" Then   '±N¦~«×¸ê®Æ©ñ¤JSheets("µn¿ý")
                  b.Offset(, 2) = a.Offset(, 7)
               Else
                   b.Offset(, 2) = b.Offset(, 2) & "/" & a.Offset(, 7)
               End If               
               a.Offset(, 8) = a.Offset(, 8) + 1    '±N¤w¥ð¤Ñ¼Æ²Ö­p©ñ¤JSheets("¯S¥ð¤Ñ¼Æ")
               d(a & b + x) = Array(a, a.Offset(, 1), b.Offset(, -1), b + x, "1", a.Offset(, 7))
            End If
         Next
      End With
   Next
Next
Sheets("list").[a65535].End(3).Offset(1).Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.Items))
Set d = Nothing
End Sub