[發問] 尋找失落的座標

cw3076

X,Y 是座標資料, 想知道資料中缺少哪些資料?
1. X 的範圍是依 X資料所找到的最小和最大, 從這個範圍中找出缺少的 X 座標.
2. 將缺少的座標顯示在另一工作表

下載 (40.92 KB)

2011-4-30 13:53

Book2.zip (3.97 KB)

下載次數: 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 ("儲存格 :  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

如果要放在不同的 Sheet 請再自行更改內容.

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

複製代碼

cw3076

Hello Luhpro,
   謝謝你的幫忙, 程式跑到一半出現找不到Y值


Dear Hsieh 版大,
  感謝~ 正解, 我會再研究研究 ~ 謝謝

GBKEE

Hello Luhpro,  謝謝你的幫忙, 程式跑到一半出現找不到Y值cw3076 發表於 2011/5/1 12:45

不會阿 !!! ,另有一解, 試試看.

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

複製代碼

GBKEE

回復 6# cw3076
每一個程序都是依不同需求而量身訂作　
   

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欄的連續範圍做排序
   
8.         If Not ActiveSheet.AutoFilter Is Nothing Then .AutoFilter  'ActiveSheet如有自動篩選 則取消
   
9.         For i = Application.Min([C:C]) To Application.Max([C:C])
   
10.             .Cells(1).AutoFilter Field:=3, Criteria1:=i   ' C欄的連續範圍做自動篩選  
    
11.             '''''''''修改 Field:= 3   Y為自動篩選的第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速度 快一些
    
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

複製代碼

cw3076

Hello GB大大,
   是的, 是第一次所附的資料不完整 and
   正解且感謝增加的程式說明 ~

luhpro

Hello Luhpro,
   謝謝你的幫忙, 程式跑到一半出現找不到Y值

抱歉. 我看錯以為中間那個表格原先就存在, 所以上面的程式是與該表格內容做比對以致有錯誤

以下為修正後的程式碼 :
Sub FindLoc()
  Dim iSource%, iX%, iY%, iDown, iLastY%, iComp%, iAns%, iNum%
  
  iDown = [C65536].End(xlUp).Row ' 找原始資料最底端
  
  Range(Cells(2, 2), Cells(iDown, 3)).Sort _  ' 原始資料排序
     Key1:=Range("C1"), _
     Key2:=Range("B1")
   
  iX = Cells(2, 2)      ' 第 2 列資料直接代入 Y 與 最小值 的X
  iLastY = Cells(2, 3)
  Cells(2, 5) = iLastY
  Cells(2, 6) = iX
  iComp = 2     ' 匯總表格
  iAns = 2      ' 缺項表格
  iSource = 3   ' 從第 3 列開始
  iNum = iX + 1 ' 遞增數字以與原始資料比對
   
  Do
  
    iY = Cells(iSource, 3) '抓下一筆資料
    iX = Cells(iSource, 2)
   
    If iLastY <> iY Then   ' Y 有新值
      Cells(iComp, 7) = Cells(iSource - 1, 2)  ' 代入上一個 Y 的 最大值 的X
      iComp = iComp + 1
      Cells(iComp, 5) = iY  '代入新的 Y 與 最小值 的X
      Cells(iComp, 6) = iX
      iNum = iX
    End If  
      
   
    Do While iNum <> iX  ' 有缺項, 代入資料到缺項表格中, 直到不再有缺項
      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) ' 帶入最後一個 最大值 的X
End Sub

回 9 樓 cw3076
不客氣.

cw3076

Dear Luhpro,
  Sorry, 我沒有說清楚
  真棒,   正解 ~ 又多了可以學習的程式了
  感恩 ~~