sss1159

回復 18# 准提部林

試了大大的方法，有個問題想問一下

　　　.Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
　　　　　　OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

我這邊想自訂搜選的排序 "桌球","羽球","桌球","籃球"
我該如何加上上述語法呢?

麻煩了 :$

准提部林

回復 21# sss1159


OFFICE 2000 沒這功能, 幫不了~~

GBKEE

回復 20# sss1159
用你的附檔 2003 沒這問題 .
回復 21# sss1159
2003 可用

下載 (62.29 KB)

2015-11-11 06:49

准提部林

回復 21# sss1159


LRR = Array("桌球", "羽球", "桌球", "籃球") 　'排序清單　
Application.AddCustomList ListArray:=LRR 　'建立清單　
Lx = Application.GetCustomListNum(LRR) 　'取得清單位置序號　

With [工作表1!A3:F3].Resize(R - 2)
     .Select
     .Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
           OrderCustom:=Lx + 1, MatchCase:=False, Orientation:=xlTopToBottom
End With
　
　
參考即可，這清單排序使用vba彈性並不好～～

准提部林

回復 21# sss1159

這是較完整的做法，清單不存在，自動建立，隨後再刪掉～～
　
Sub 排序()
Dim R&, LRR, Lm%, Lx%
R = [工作表1!A1].Cells(Rows.Count, 1).End(xlUp).Row
If R < 4 Then Exit Sub
　
LRR = Split("藍球_排球_棒球_足球_桌球", "_") 　'排序清單
With Application
　　　Lm = .GetCustomListNum(LRR) 　'檢查清單的位置
　　　If Lm = 0 Then .AddCustomList ListArray:=LRR 　'清單不存在,建立
　　　Lx = .GetCustomListNum(LRR) 　'取得清單位置序號
End With
　
With [工作表1!A3:F3].Resize(R - 2)
　　　.Select
　　　.Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
　　　　　　OrderCustom:=Lx + 1, MatchCase:=False, Orientation:=xlTopToBottom
End With
　
If Lm = 0 Then Application.DeleteCustomList ListNum:=Lx 　'清單若是本次建立,刪除清單
End Sub

sss1159

回復 25# 准提部林

非常感謝兩位板主的回覆><

Sub 排序()
Dim R&, LRR, Lm%, Lx%
R = [工作表1!A1].Cells(Rows.Count, 1).End(xlUp).Row
If R < 4 Then Exit Sub
　
LRR = Split("藍球_排球_棒球_足球_桌球", "_") 　'排序清單
With Application
　　　Lm = .GetCustomListNum(LRR) 　'檢查清單的位置
　　　If Lm = 0 Then .AddCustomList ListArray:=LRR 　'清單不存在,建立
　　　Lx = .GetCustomListNum(LRR) 　'取得清單位置序號
End With
　
With [工作表1!A3:F3].Resize(R - 2)
　　　.Select
　　　.Sort Key1:=.Item(6), Order1:=xlAscending, Header:=xlYes, _
　　　　　　OrderCustom:=Lx + 1, MatchCase:=False, Orientation:=xlTopToBottom
End With
　
If Lm = 0 Then Application.DeleteCustomList ListNum:=Lx 　'清單若是本次建立,刪除清單
End Sub

使用了這個方法確實可以順利的排序，
但只要按下存檔，整個EXCEL 就會當掉了....
看來似乎只能用GB版大 的手動資料排序了:Q

sss1159

HI ，玩一玩上述的公式又回來發問了:P

1.
Sub 篩選()
    Dim X$
    X = Application.InputBox("請輸入篩選關鍵字")
    If X = "" Or X = "False" Then Exit Sub
    With Sheets("工作表1").[A3]  '
        .Parent.AutoFilterMode = False
        
        .AutoFilter Field:=1, Criteria1:="*" & X & "*"
        If .End(xlDown).Row = Rows.Count Then MsgBox "找不到資料!!": Exit Sub
        .CurrentRegion.Sort Key1:=.Range("C3"), Order1:=xlAscending, Header:=xlYes
    End With
End Sub

原本搜尋的是第一欄 班級，若我想搜尋的是第四欄 性別
我該如何修改呢? 我數字都改過了><"


2.
Sub 搜尋()
Dim X$, R&, xSht As Worksheet, M, j&, Jm&, xH As Range
R = ActiveSheet.UsedRange.Rows.Count
If R > 5 Then Rows("6:" & R).Delete
X = Application.InputBox("請輸入搜尋關鍵字")
If X = "" Or X = "False" Then Exit Sub
For Each xSht In Sheets(Array("工作表1", "工作表3", "工作表4"))
    Set xH = Range(Array("A6", "I6", "P6")(M))
    M = M + 1: Jm = 0
    With xSht
          For j = 4 To .Cells(Rows.Count, 1).End(xlUp).Row
              If InStr(.Cells(j, 1) & .Cells(j, 2), X) Then
                  Jm = Jm + 1
                  .Cells(j, 1).Resize(1, 6).Copy xH(Jm)
              End If
          Next j
          If Jm = 0 Then MsgBox "〔" & .Name & "〕找不到〔" & X & "〕相關資料!!":
         
    End With
Next
End Sub

工作表2的搜尋 想增加另一種方式
不使用INPUTBOX ，直接改成 籃球或排球 兩種結果都搜尋出來
該如何修改呢


再麻煩指教，教導了，感謝再感謝

准提部林

回復 27# sss1159


For j = 4 To .Cells(Rows.Count, 1).End(xlUp).Row
　　If Instr("藍球排球", .Cells(j, 6)) Then
　　　　Jm = Jm + 1
　　　　.Cells(j, 1).Resize(1, 6).Copy xH(Jm)
　　End If
Next j

GBKEE

回復 27# sss1159

1. '最愛的運動=>F欄
   
2.     .AutoFilter Field:=6, Criteria1:="=藍球", Operator:=xlOr, Criteria2:="=排球"

複製代碼

不知VBA程式碼如何編寫,可錄製巨集練習

下載 (73.47 KB)

2015-11-13 06:23

v03586

請問VBA搜尋方式只能用篩選的嗎?
能不能像談出一個畫面 下面顯示你搜尋的關鍵字呢?