12
返回列表 上一主題 發帖

[發問] ➽篩選G欄>H欄>I欄

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
17  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
11# 跳轉到 »
發表於 2020-11-18 10:05 | 只看該作者
  1. Sub zz()
  2. Dim rng As Range, a, b, i&, j&, k&, n&, m&
  3. With Sheets(1)
  4.     Set rng = .Range("c2:l" & .[b2].End(4).Row)
  5.     a = rng.Value: b = a
  6. End With
  7. j = rng(1).Column - 1
  8. c = Split(InputBox("輸入列號以豆號間開", , "G,H,I"), ",")
  9. For i = 0 To UBound(c)
  10.     c(i) = Columns(c(i)).Column - j
  11. Next
  12. n = UBound(c): m = 1
  13. For i = 2 To UBound(a)
  14.     k = 0
  15.     For j = 0 To n - 1
  16.         If a(i, c(j)) > a(i, c(j + 1)) Then k = k + 1
  17.     Next
  18.     If k = n Then
  19.         m = m + 1
  20.         For j = 1 To UBound(a, 2)
  21.             b(n, j) = a(i, j)
  22.         Next
  23.     End If
  24. Next
  25. With Sheets(2)
  26.     .UsedRange.Clear
  27.     .[a1].Resize(m, UBound(b, 2)) = b
  28. End With
  29. End Sub
複製代碼

TOP

jcchiang

帖子
234 
主題
19 
精華
0 
積分
276 
點名
0  
作業系統
Windows XP 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
註冊時間
2013-1-7 
最後登錄
2021-10-7 
12#
發表於 2020-11-18 12:23 | 只看該作者
回復 10# peter95

只是大於 & 小於的變更,應該沒這麼困難吧!
    If arr(x, 7) < arr(x, 8) And arr(x, 8) < arr(x, 9) And arr(x, 9) < arr(x, 10) Then Set c = Union(c, arr(x, 3).Resize(, 10))

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
17  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
13#
發表於 2020-11-18 14:35 | 只看該作者
回復 10# peter95
  1. Sub zz()
  2. Dim rng As Range, a, b, i&, j&, k&, n&, m&, s
  3. With Sheets(1)
  4.     Set rng = .Range("c2:l" & .[b2].End(4).Row)
  5.     a = rng.Value: b = a
  6. End With
  7. j = rng(1).Column - 1
  8. c = InputBox("輸入列號以比較號間開", , "G<H<I")
  9. s = Mid(c, 2, 1): c = Split(c, s)
  10. For i = 0 To UBound(c)
  11.     c(i) = Columns(c(i)).Column - j
  12. Next
  13. n = UBound(c): m = 1
  14. For i = 2 To UBound(a)
  15.     k = 0
  16.     If s = "<" Then Call L(a, i, c, n, k) Else Call G(a, i, c, n, k)
  17.     If k = n Then
  18.         m = m + 1
  19.         For j = 1 To UBound(a, 2)
  20.             b(n, j) = a(i, j)
  21.         Next
  22.     End If
  23. Next
  24. With Sheets(2)
  25.     .UsedRange.Clear
  26.     .[a1].Resize(m, UBound(b, 2)) = b
  27. End With
  28. End Sub
複製代碼
  1. Sub G(a, i, c, n, k)
  2.     For j = 0 To n - 1
  3.         If a(i, c(j)) > a(i, c(j + 1)) Then k = k + 1
  4.     Next
  5. End Sub
複製代碼
  1. Sub L(a, i, c, n, k)
  2.     For j = 0 To n - 1
  3.         If a(i, c(j)) < a(i, c(j + 1)) Then k = k + 1
  4.     Next
  5. End Sub
複製代碼

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
14#
發表於 2024-1-25 09:53 | 只看該作者
謝謝論壇,謝謝各位前輩
後學藉此帖以1#範例練習儲存格聯集,擴張與交集,學習方案如下,請各位前輩指教

Option Explicit
Sub TEST()
Dim i&, xA As Range, xU As Range
Set xA = Range([Sheet1!L2], [Sheet1!C65536].End(3))
Set xU = xA(1)
For i = 2 To xA.Rows.Count
   If (Val(xA(i, 5)) > Val(xA(i, 6))) * (Val(xA(i, 6)) > Val(xA(i, 7))) = 1 Then
      Set xU = Union(xU, xA(i, 1))
   End If
Next
Intersect(xU.EntireRow, [Sheet1!C:L]).Copy [工作表1!A1]
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 【時間無法遮擋】怕時間消逝，花了許多心血，想盡各式方法要遮擋時間，結果是：浪費了更多時間，且一無所成！
12
返回列表 上一主題