Hsieh

¦^´_ 1# metrostar

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim A As Range, C As Range, Ar()
   
3. If Intersect(Target, [H2]) Is Nothing Then Exit Sub
   
4. Set A = [E:E].Find(Target, lookat:=xlWhole)
   
5. If A Is Nothing Then Exit Sub
   
6. ReDim Preserve Ar(s)
   
7. Ar(s) = Array([B1].Value, [C1].Value, [D1].Value, [F1].Value)
   
8. s = s + 1
   
9.    For Each C In A.MergeArea
   
10.      ReDim Preserve Ar(s)
    
11.      Ar(s) = Array(C.Offset(, -3).MergeArea(1).Value, C.Offset(, -2).MergeArea(1).Value, C.Offset(, -1).MergeArea(1).Value, C.Offset(, 1).MergeArea(1).Value)
    
12.      s = s + 1
    
13.     Next
    
14. Application.EnableEvents = False
    
15. [I:L] = ""
    
16. With Range("I1")
    
17.    .Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
    
18.    .CurrentRegion.Offset(, 1).Sort key1:=.Range("A1"), Header:=xlYes
    
19. End With
    
20. Application.EnableEvents = True
    
21. End Sub

½Æ»s¥N½X