返回列表 上一主題 發帖

[發問] 尋找失落的座標

cw3076

帖子
42 
主題
12 
精華
0 
積分
283 
點名
1  
作業系統
WINDOWS XP 
軟體版本
SP2 
閱讀權限
20 
來自
KAOHSIUNG 
註冊時間
2010-5-8 
最後登錄
2024-8-13 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-4-30 13:54 | 只看該作者

[發問] 尋找失落的座標

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




Book2.zip (3.97 KB)
收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 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 請再自行更改內容.

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
256  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-26 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2011-4-30 23:44 | 只看該作者
  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")

  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
複製代碼
學海無涯_不恥下問

TOP

cw3076

帖子
42 
主題
12 
精華
0 
積分
283 
點名
1  
作業系統
WINDOWS XP 
軟體版本
SP2 
閱讀權限
20 
來自
KAOHSIUNG 
註冊時間
2010-5-8 
最後登錄
2024-8-13 
4#
發表於 2011-5-1 12:45 | 只看該作者
Hello Luhpro,
   謝謝你的幫忙, 程式跑到一半出現找不到Y值


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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2011-5-1 14:55 | 只看該作者
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
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2011-5-1 19:57 | 只看該作者
回復 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
複製代碼

TOP

cw3076

帖子
42 
主題
12 
精華
0 
積分
283 
點名
1  
作業系統
WINDOWS XP 
軟體版本
SP2 
閱讀權限
20 
來自
KAOHSIUNG 
註冊時間
2010-5-8 
最後登錄
2024-8-13 
7#
發表於 2011-5-1 21:04 | 只看該作者
本帖最後由 cw3076 於 2011-5-1 23:32 編輯

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

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
8#
發表於 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
不客氣.

TOP

cw3076

帖子
42 
主題
12 
精華
0 
積分
283 
點名
1  
作業系統
WINDOWS XP 
軟體版本
SP2 
閱讀權限
20 
來自
KAOHSIUNG 
註冊時間
2010-5-8 
最後登錄
2024-8-13 
9#
發表於 2011-5-1 23:30 | 只看該作者
Dear Luhpro,
  Sorry, 我沒有說清楚
  真棒,   正解 ~ 又多了可以學習的程式了
  感恩 ~~

TOP

        靜思自在 : 能善用時間的人，必能掌握自己努力的方向。
返回列表 上一主題