返回列表 上一主題 發帖

[發問] 尋找失落的座標

Hsieh

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

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

        靜思自在 : 成功是優點的發揮，失敗是缺點的累積。
返回列表 上一主題