麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 尋找失落的座標 [打印本頁]

作者: cw3076 時間: 2011-4-30 13:54 標題: 尋找失落的座標

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

[attach]5920[/attach]

[attach]5921[/attach]

作者: luhpro 時間: 2011-4-30 21:48

本帖最後由 luhpro 於 2011-4-30 21:51 編輯

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 時間: 2011-4-30 23:44

Sub ex()
Dim Ar(), a, s%
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each a In Range([B2], [B65536].End(xlUp))
d(a & a.Offset(, 1)) = d.Count
If IsEmpty(d1(a.Offset(, 1).Value)) Then
d1(a.Offset(, 1).Value) = a
ElseIf a < d1(a.Offset(, 1).Value) Then
d1(a.Offset(, 1).Value) = a
End If
If IsEmpty(d2(a.Offset(, 1).Value)) Then
d2(a.Offset(, 1).Value) = a
ElseIf a > d2(a.Offset(, 1).Value) Then
d2(a.Offset(, 1).Value) = a
End If
Next
For Each a In d1.keys
For i = d1(a) To d2(a)
If d.exists(i & a) = False Then
ReDim Preserve Ar(s)
Ar(s) = Array(i, a)
s = s + 1
End If
Next
Next
[E2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
[F2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
[G2].Resize(d1.Count, 1) = Application.Transpose(d2.items)
[I2].Resize(s, 2) = Application.Transpose(Application.Transpose(Ar))
End Sub

複製代碼

作者: cw3076 時間: 2011-5-1 12:45

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

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

作者: GBKEE 時間: 2011-5-1 14:55

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

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

Sub Ex()
Dim i As Integer, ii As Integer, Rng As Range, A%, x%
ReDim Ar%(2, A)
ReDim Xy&(1, x)
With ActiveSheet.[C:C].SpecialCells(xlCellTypeConstants)
If Not ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
For i = Application.Min([C:C]) To Application.Max([C:C])
.Cells(1).AutoFilter Field:=2, Criteria1:=i
Set Rng = .SpecialCells(xlCellTypeVisible)
Set Rng = Rng.Areas(Rng.Areas.Count).Offset(, -1)
Ar(0, A) = i
Ar(1, A) = Application.Min(Rng)
Ar(2, A) = Application.Max(Rng)
For ii = Ar(1, A) To Ar(2, A)
If Rng.Find(ii) Is Nothing Then
Xy(0, x) = ii
Xy(1, x) = i
x = x + 1
ReDim Preserve Xy(1, x)
End If
Next
A = A + 1: ReDim Preserve Ar(2, A)
Next
.Cells(1).AutoFilter
End With
ActiveSheet.[E2].Resize(A, 3) = Application.Transpose(Ar)
ActiveSheet.[I2].Resize(x, 2) = Application.Transpose(Xy)
End Sub

複製代碼

作者: GBKEE 時間: 2011-5-1 19:57

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

Sub Ex()
Dim i As Integer, ii As Integer, Rng As Range, A%, x%
ReDim Ar%(2, A)
ReDim Xy%(1, x)
With ActiveSheet.[C:C].SpecialCells(xlCellTypeConstants)
.Cells(1).CurrentRegion.Sort Key1:=.Cells(1), Header:=xlYes, Order1:=xlAscending
' C欄的連續範圍做排序
If Not ActiveSheet.AutoFilter Is Nothing Then .AutoFilter 'ActiveSheet如有自動篩選則取消
For i = Application.Min([C:C]) To Application.Max([C:C])
.Cells(1).AutoFilter Field:=3, Criteria1:=i ' C欄的連續範圍做自動篩選
'''''''''修改 Field:= 3 Y為自動篩選的第3個欄位'''''''''
Set Rng = .SpecialCells(xlCellTypeVisible)
Set Rng = Rng.Areas(Rng.Areas.Count).Offset(, -1)
Ar(0, A) = i
Ar(1, A) = Application.Min(Rng)
Ar(2, A) = Application.Max(Rng)
For ii = Ar(1, A) To Ar(2, A)
If IsError(Application.Match(ii, Rng, 0)) Then
'If Rng.Find(ii) Is Nothing Then 改用Match速度快一些
Xy(0, x) = ii
Xy(1, x) = i
x = x + 1
ReDim Preserve Xy(1, x)
End If
Next
A = A + 1: ReDim Preserve Ar(2, A)
Next
.Cells(1).AutoFilter
End With
ActiveSheet.[E2].Resize(A, 3) = Application.Transpose(Ar)
ActiveSheet.[I2].Resize(x, 2) = Application.Transpose(Xy)
End Sub

複製代碼

作者: cw3076 時間: 2011-5-1 21:04

本帖最後由 cw3076 於 2011-5-1 23:32 編輯

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

作者: luhpro 時間: 2011-5-1 22:20

本帖最後由 luhpro 於 2011-5-1 23:35 編輯

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 時間: 2011-5-1 23:30

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)