GBKEE

¦^´_ 3# b31978
¸Õ¸Õ¬Ý

1. '¤@¯ë¼Ò²Õµ{¦¡½X
   
2. Option Explicit
   
3. Sub Ex()
   
4.     Dim Rng As Range, C As Range, S, Ar(), At(), i As Integer
   
5.     Set Rng = ActiveSheet.Range("A3")
   
6.     Do While Rng <> ""
   
7.         With Rng.Offset(, 2).Resize(Rng.MergeArea.Count, 7)
   
8.         'Rng.MergeArea Àx¦s®æªº¦X¨Ö½d³ò
   
9.         'Rng.MergeArea.Count ¦X¨Ö½d³òªºCellsÁ`­p
   
10.             If Application.CountA(.Cells) > 0 Then '.Cells :³o With ª«¥ó½d³òRangeªºCells
    
11.                 '¤u§@ªí¨ç¼Æ CountA ­pºâ½d³ò¤º¦³¸ê®ÆªºCells­Ó¼Æ
    
12.                 For Each C In .SpecialCells(xlCellTypeConstants)
    
13.                     'SpecialCells ¯S®íÀx¦s®æ (xlCellTypeConstants :¦r¦ê,¼Æ¦r )
    
14.                     ReDim Ar(1 To 4)      '­«¸m°}¦C
    
15.                     Ar(1) = Rng.Value
    
16.                     Ar(2) = Cells(2, C.Column)
    
17.                     Ar(3) = C
    
18.                     Ar(4) = Cells(C.Row, "j")
    
19.                     i = i + 1
    
20.                     ReDim Preserve At(1 To i)  '­«¸m°}¦C:Preserve«O¯d­ì¦³ªº¤¸¯À
    
21.                     At(i) = Ar
    
22.                 Next
    
23.             End If
    
24.         End With
    
25.         Set Rng = Rng.End(xlDown) '¤U¤@­Ó¦³¦X¨Ö½d³òªºRange
    
26.     Loop
    
27.     If i > 0 Then [M3].Resize(i, 4) = Application.Transpose(Application.Transpose(At))
    
28. End Sub

½Æ»s¥N½X