[µo°Ý] ´M§ä¥¢¸¨ªº®y¼Ð

cw3076

X,Y ¬O®y¼Ð¸ê®Æ, ·Qª¾¹D¸ê®Æ¤¤¯Ê¤Ö­þ¨Ç¸ê®Æ?
1. X ªº½d³ò¬O¨Ì X¸ê®Æ©Ò§ä¨ìªº³Ì¤p©M³Ì¤j, ±q³o­Ó½d³ò¤¤§ä¥X¯Ê¤Öªº X ®y¼Ð.
2. ±N¯Ê¤Öªº®y¼ÐÅã¥Ü¦b¥t¤@¤u§@ªí

¤U¸ü (40.92 KB)

2011-4-30 13:53

Book2.zip (3.97 KB)

¤U¸ü¦¸¼Æ: 16

2011-4-30 13:54

luhpro

Sub FindLoc()
  Dim iNum%, iY%, iDown%, iKey%, iI%, iLastY%, iAns%
  Dim c
  
  iDown = [C65536].End(xlUp).Row
  
  Range(Cells(2, 2), Cells(iDown, 3)).Sort _
     Key1:=Range("C1"), _
     Key2:=Range("B1")
  
  iNum = 2
  iLastY = 0
  iAns = 2
  
  Do
    iY = Cells(iNum, 3)
   
    If iLastY <> iY Then
      With Range(Cells(2, 5), Cells([E65535].End(xlUp).Row, 5))
        Set c = .Find(iY, LookIn:=xlValues)
        If Not c Is Nothing Then
          iKey = c.Row
        Else
          MsgBox ("Àx¦s®æ :  C" + Right(Str(iNum), Len(Str(iNum)) - 1) + " ªº Y ­È¬° " + Str(iY) + " §ä¤£¨ì!")
          Exit Sub
        End If
      End With
    End If
  
    For iI = Cells(iKey, 6) To Cells(iKey, 7)
      If Cells(iNum, 2) <> iI Then
        Cells(iAns, 9) = iI
        Cells(iAns, 10) = iY
        iAns = iAns + 1
      Else
        iNum = iNum + 1
      End If
    Next iI
    iLastY = iY
  
  Loop While iNum <= iDown
End Sub

¦pªG­n©ñ¦b¤£¦Pªº Sheet ½Ð¦A¦Û¦æ§ó§ï¤º®e.

Hsieh

1. Sub ex()
   
2. Dim Ar(), a, s%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. Set d2 = CreateObject("Scripting.Dictionary")
   
6. 
   
7. For Each a In Range([B2], [B65536].End(xlUp))
   
8.    d(a & a.Offset(, 1)) = d.Count
   
9.    If IsEmpty(d1(a.Offset(, 1).Value)) Then
   
10.       d1(a.Offset(, 1).Value) = a
    
11.    ElseIf a < d1(a.Offset(, 1).Value) Then
    
12.       d1(a.Offset(, 1).Value) = a
    
13.    End If
    
14.    If IsEmpty(d2(a.Offset(, 1).Value)) Then
    
15.       d2(a.Offset(, 1).Value) = a
    
16.    ElseIf a > d2(a.Offset(, 1).Value) Then
    
17.       d2(a.Offset(, 1).Value) = a
    
18.    End If
    
19. Next
    
20. For Each a In d1.keys
    
21.   For i = d1(a) To d2(a)
    
22.   If d.exists(i & a) = False Then
    
23.      ReDim Preserve Ar(s)
    
24.      Ar(s) = Array(i, a)
    
25.      s = s + 1
    
26.   End If
    
27.   Next
    
28. Next
    
29. [E2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
30. [F2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
    
31. [G2].Resize(d1.Count, 1) = Application.Transpose(d2.items)
    
32. [I2].Resize(s, 2) = Application.Transpose(Application.Transpose(Ar))
    
33. End Sub

½Æ»s¥N½X

cw3076

Hello Luhpro,
   ÁÂÁ§AªºÀ°¦£, µ{¦¡¶]¨ì¤@¥b¥X²{§ä¤£¨ìY­È


Dear Hsieh ª©¤j,
  ·PÁÂ~ ¥¿¸Ñ, §Ú·|¦A¬ã¨s¬ã¨s ~ ÁÂÁÂ

GBKEE

Hello Luhpro,  ÁÂÁ§AªºÀ°¦£, µ{¦¡¶]¨ì¤@¥b¥X²{§ä¤£¨ìY­Ècw3076 µoªí©ó 2011/5/1 12:45

¤£·|ªü !!! ,¥t¦³¤@¸Ñ, ¸Õ¸Õ¬Ý.

1. Sub Ex()
   
2.     Dim i As Integer, ii As Integer, Rng As Range, A%, x%
   
3.     ReDim Ar%(2, A)
   
4.     ReDim Xy&(1, x)
   
5.     With ActiveSheet.[C:C].SpecialCells(xlCellTypeConstants)
   
6.         If Not ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
   
7.         For i = Application.Min([C:C]) To Application.Max([C:C])
   
8.             .Cells(1).AutoFilter Field:=2, Criteria1:=i
   
9.             Set Rng = .SpecialCells(xlCellTypeVisible)
   
10.             Set Rng = Rng.Areas(Rng.Areas.Count).Offset(, -1)
    
11.             Ar(0, A) = i
    
12.             Ar(1, A) = Application.Min(Rng)
    
13.             Ar(2, A) = Application.Max(Rng)
    
14.             For ii = Ar(1, A) To Ar(2, A)
    
15.                 If Rng.Find(ii) Is Nothing Then
    
16.                     Xy(0, x) = ii
    
17.                     Xy(1, x) = i
    
18.                     x = x + 1
    
19.                     ReDim Preserve Xy(1, x)
    
20.                 End If
    
21.             Next
    
22.             A = A + 1:   ReDim Preserve Ar(2, A)
    
23.         Next
    
24.         .Cells(1).AutoFilter
    
25.     End With
    
26.     ActiveSheet.[E2].Resize(A, 3) = Application.Transpose(Ar)
    
27.     ActiveSheet.[I2].Resize(x, 2) = Application.Transpose(Xy)
    
28. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 6# cw3076
¨C¤@­Óµ{§Ç³£¬O¨Ì¤£¦P»Ý¨D¦Ó¶q¨­­q§@¡@
   

1. Sub Ex()
   
2.     Dim i As Integer, ii As Integer, Rng As Range, A%, x%
   
3.     ReDim Ar%(2, A)
   
4.     ReDim Xy%(1, x)
   
5.     With ActiveSheet.[C:C].SpecialCells(xlCellTypeConstants)
   
6.          .Cells(1).CurrentRegion.Sort Key1:=.Cells(1), Header:=xlYes, Order1:=xlAscending
   
7.          ' CÄ檺³sÄò½d³ò°µ±Æ§Ç
   
8.         If Not ActiveSheet.AutoFilter Is Nothing Then .AutoFilter  'ActiveSheet¦p¦³¦Û°Ê¿z¿ï «h¨ú®ø
   
9.         For i = Application.Min([C:C]) To Application.Max([C:C])
   
10.             .Cells(1).AutoFilter Field:=3, Criteria1:=i   ' CÄ檺³sÄò½d³ò°µ¦Û°Ê¿z¿ï  
    
11.             '''''''''­×§ï Field:= 3   Y¬°¦Û°Ê¿z¿ïªº²Ä3­ÓÄæ¦ì'''''''''
    
12.             Set Rng = .SpecialCells(xlCellTypeVisible)
    
13.             Set Rng = Rng.Areas(Rng.Areas.Count).Offset(, -1)
    
14.             Ar(0, A) = i
    
15.             Ar(1, A) = Application.Min(Rng)
    
16.             Ar(2, A) = Application.Max(Rng)
    
17.             For ii = Ar(1, A) To Ar(2, A)
    
18.                 If IsError(Application.Match(ii, Rng, 0)) Then
    
19.                 'If Rng.Find(ii) Is Nothing Then  §ï¥ÎMatch³t«× §Ö¤@¨Ç
    
20.                     Xy(0, x) = ii
    
21.                     Xy(1, x) = i
    
22.                     x = x + 1
    
23.                     ReDim Preserve Xy(1, x)
    
24.                 End If
    
25.             Next
    
26.             A = A + 1:   ReDim Preserve Ar(2, A)
    
27.         Next
    
28.         .Cells(1).AutoFilter
    
29.     End With
    
30.     ActiveSheet.[E2].Resize(A, 3) = Application.Transpose(Ar)
    
31.     ActiveSheet.[I2].Resize(x, 2) = Application.Transpose(Xy)
    
32. End Sub

½Æ»s¥N½X

cw3076

Hello GB¤j¤j,
   ¬Oªº, ¬O²Ä¤@¦¸©Òªþªº¸ê®Æ¤£§¹¾ã and
   ¥¿¸Ñ¥B·PÁ¼W¥[ªºµ{¦¡»¡©ú ~

luhpro

Hello Luhpro,
   ÁÂÁ§AªºÀ°¦£, µ{¦¡¶]¨ì¤@¥b¥X²{§ä¤£¨ìY­È

©êºp. §Ú¬Ý¿ù¥H¬°¤¤¶¡¨º­Óªí®æ­ì¥ý´N¦s¦b, ©Ò¥H¤W­±ªºµ{¦¡¬O»P¸Óªí®æ¤º®e°µ¤ñ¹ï¥H­P¦³¿ù»~

¥H¤U¬°­×¥¿«áªºµ{¦¡½X :
Sub FindLoc()
  Dim iSource%, iX%, iY%, iDown, iLastY%, iComp%, iAns%, iNum%
  
  iDown = [C65536].End(xlUp).Row ' §ä­ì©l¸ê®Æ³Ì©³ºÝ
  
  Range(Cells(2, 2), Cells(iDown, 3)).Sort _  ' ­ì©l¸ê®Æ±Æ§Ç
     Key1:=Range("C1"), _
     Key2:=Range("B1")
   
  iX = Cells(2, 2)      ' ²Ä 2 ¦C¸ê®Æª½±µ¥N¤J Y »P ³Ì¤p­È ªºX
  iLastY = Cells(2, 3)
  Cells(2, 5) = iLastY
  Cells(2, 6) = iX
  iComp = 2     ' ¶×Á`ªí®æ
  iAns = 2      ' ¯Ê¶µªí®æ
  iSource = 3   ' ±q²Ä 3 ¦C¶}©l
  iNum = iX + 1 ' »¼¼W¼Æ¦r¥H»P­ì©l¸ê®Æ¤ñ¹ï
   
  Do
  
    iY = Cells(iSource, 3) '§ì¤U¤@µ§¸ê®Æ
    iX = Cells(iSource, 2)
   
    If iLastY <> iY Then   ' Y ¦³·s­È
      Cells(iComp, 7) = Cells(iSource - 1, 2)  ' ¥N¤J¤W¤@­Ó Y ªº ³Ì¤j­È ªºX
      iComp = iComp + 1
      Cells(iComp, 5) = iY  '¥N¤J·sªº Y »P ³Ì¤p­È ªºX
      Cells(iComp, 6) = iX
      iNum = iX
    End If  
      
   
    Do While iNum <> iX  ' ¦³¯Ê¶µ, ¥N¤J¸ê®Æ¨ì¯Ê¶µªí®æ¤¤, ª½¨ì¤£¦A¦³¯Ê¶µ
      Cells(iAns, 9) = iNum
      Cells(iAns, 10) = iY
      iAns = iAns + 1
      iNum = iNum + 1
    Loop
   
    iSource = iSource + 1
    iNum = iNum + 1
    iLastY = iY
  
  Loop While iSource <= iDown   ' ¤ñ¸û§¹²¦
  Cells(iComp, 7) = Cells(iSource - 1, 2) ' ±a¤J³Ì«á¤@­Ó ³Ì¤j­È ªºX
End Sub

¦^ 9 ¼Ó cw3076
¤£«È®ð.

cw3076

Dear Luhpro,
  Sorry, §Ú¨S¦³»¡²M·¡
  ¯u´Î,   ¥¿¸Ñ ~ ¤S¦h¤F¥i¥H¾Ç²ßªºµ{¦¡¤F
  ·P®¦ ~~