ikboy

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

複製代碼

jcchiang

回復 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))

ikboy

回復 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

複製代碼

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖以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