返回列表 上一主題 發帖

[發問] 尋找失落的座標

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
1  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
1# 跳轉到 »
發表於 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

luhpro

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

        靜思自在 : 為人處世要小心細心，但不要「小心眼」。
返回列表 上一主題