返回列表 上一主題 發帖

[發問] VBA 搜尋的問題

回復 3# sss1159


〔工作表1〕
再點選 取消搜尋
即可恢復原本未搜尋前的資料

A:D欄即是原本資料,搜尋並未動到此部份,何來〔恢復原本未搜尋前的資料〕???

TOP

回復 6# sss1159


Sub 篩選()
Dim X$
X = Application.InputBox("請輸入篩選關鍵字")
If X = "" Or X = "False" Then Exit Sub
With Range([A3], Cells(Rows.Count, 1).End(xlUp))
     If .Offset(1, 0).Find(X, Lookat:=xlPart) Is Nothing Then MsgBox "找不到資料!!": Exit Sub
    .AutoFilter Field:=1, Criteria1:="*" & X & "*"
End With
End Sub

'================================
Sub 篩選解除()
ActiveSheet.AutoFilterMode = False
End Sub

TOP

<工作表2> 

Sub 搜尋()
Dim X$, R&, xSht As Worksheet, M, j&, Jm&, xH As Range
R = ActiveSheet.UsedRange.Rows.Count
If R > 3 Then Rows("4:" & R).Delete
X = Application.InputBox("請輸入搜尋關鍵字")
If X = "" Or X = "False" Then Exit Sub
For Each xSht In Sheets(Array("工作表1", "工作表3"))
  Set xH = Range(Array("A4", "H4")(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, 4).Copy xH(Jm)
       End If
     Next j
     If Jm = 0 Then MsgBox "〔" & .Name & "〕找不到〔" & X & "〕相關資料!!":
  End With
Next
End Sub

TOP

本帖最後由 准提部林 於 2015-11-10 09:59 編輯

回復 9# sss1159


R = Range([A1], ActiveSheet.UsedRange).Rows.Count
_請改成如上,以防〔標題列〕以上未使用,UsedRange會不包涵這範圍
If R > 3 Then Rows("4:" & R).Delete
_〔標題列〕在第3列,若超過3才表示底下有資料,再清空

大凡表格結構會有〔表首〕〔標題列〕〔資料明細〕,皆以〔標題列〕為區隔線

這段是指要載入查詢資料的工作表,亦即執行vba的〔當前頁〕

TOP

回復 10# 准提部林


For j = 4 To .Cells(Rows.Count, 1).End(xlUp).Row

4為查詢資料〔來源〕工作表〔資料明細〕的〔起始列〕,與上方的4不相關,
一個是查詢表,一個是資料表,只是剛好都從第4列開始,
__不同工作表必須有固定的表格結構,否則容易出錯∼∼

其它大致都對∼∼

TOP

回復 12# sss1159

排序程式碼最上方加入:
ActiveSheet.AutoFilterMode = False

注意:篩選狀態時,若不先解除篩選,任何操作都可能造成無法彌補的錯誤(尤其是已執行了儲存結果)

TOP

本帖最後由 准提部林 於 2015-11-10 13:29 編輯

回復 14# sss1159

Sub 排序()
Dim R&
R = [工作表1!A1].Cells(Rows.Count, 1).End(xlUp).Row
If R < 4 Then Exit Sub
With [工作表1!A3:E3].Resize(R - 2)
   .Select '這可以刪掉 
   .Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlYes, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub

.Item(5) 即是E欄的標題〔新增日期〕!
再提醒:〔篩選〕狀態中,儘量不做〔排序〕,也不從它處貼資料進來,會造成資料錯亂

TOP

回復 21# sss1159


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

TOP

回復 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彈性並不好∼∼

TOP

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

TOP

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