1234567
返回列表 上一主題 發帖

[發問] 篩選?關鍵字?查詢?

emma

帖子
110 
主題
14 
精華
0 
積分
239 
點名
0  
作業系統
win xp 
軟體版本
office 2003 
閱讀權限
20 
性別
女 
註冊時間
2010-8-2 
最後登錄
2017-5-10 

有您真好勳章
41# 跳轉到 »
發表於 2012-12-18 17:30 | 只看該作者
回復 40# GBKEE


    GBKEE版主，只有第一筆可以，但之後的就又沒作用了耶，連篩選也動不了(如圖二)
   
   

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
42#
發表於 2012-12-19 08:49 | 只看該作者
回復 41# emma
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim Target_Row As String, s As Integer, dot As Long, k As Integer, m As String
  4.     Dim Ar(), A As Range, Rng As Range
  5.     If Target.Address(0, 0) = "E1" Then
  6.         Range("D3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
  7.     ElseIf Target.Address(0, 0) = "C1" Then
  8.         Range("C3").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
  9.     Else
  10.         Exit Sub                                  '*****
  11.     End If
  12.     Application.EnableEvents = False              '****
  13.     Set Rng = Range("B4:B65536").SpecialCells(xlCellTypeVisible)     '自動篩選後可見的儲存格
  14.     If Application.Count(Rng) > 0 Then                                                      '可見的儲存格:有資料儲存格的總數>0
  15.         Set Rng = Rng.SpecialCells(xlCellTypeConstants)                         '可見的儲存格:有資料的儲存格
  16.             For Each A In Rng.Cells
  17.                 ReDim Preserve Ar(s)
  18.                 If A.Offset(, 8) = "V" And A.Offset(, 9) >= Date And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  19.                 k = IIf(Sheets("查詢").[B1] = "總店", 10, 11)
  20.                 If A.Offset(, 7) < Date Then
  21.                     m = "已結束"
  22.                 ElseIf A < A.Offset(, 4) Then
  23.                     m = "運費+手續費"
  24.                 ElseIf InStr(A.Offset(, 5), "推") And A > A.Offset(, 4) Then       '包含
  25.                     m = "免運"
  26.                 ElseIf InStr(A.Offset(, 5), "推") = 0 And A > A.Offset(, 4) Then   '不包含
  27.                     m = "運費"
  28.                 End If
  29.                 Ar(s) = Array(A.Offset(, 2).Value, A.Value, A.Offset(, 3).Value, dot, A.Offset(, 12).Value, A.Offset(, k).Value, m, A.Offset(, 6).Value)
  30.                 s = s + 1
  31.             Next
  32.     End If
  33.     With Sheets("查詢")
  34.         If s > 0 Then
  35.             Target = ""
  36.             .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  37.             Sheets("資料檔").[C2] = .Range("A" & .Rows.Count).End(xlUp).Offset(, 5)   'F欄:儲位
  38.         End If
  39.     End With
  40.     Application.EnableEvents = True                 '*******
  41. End Sub
複製代碼

TOP

emma

帖子
110 
主題
14 
精華
0 
積分
239 
點名
0  
作業系統
win xp 
軟體版本
office 2003 
閱讀權限
20 
性別
女 
註冊時間
2010-8-2 
最後登錄
2017-5-10 

有您真好勳章
43#
發表於 2012-12-19 11:57 | 只看該作者
回復 42# GBKEE


    謝謝GBKEE版大，在測試的過程中，還是無法順利新增至查詢裡，不曉得是哪裡出了問題，
    後來發現在輸入完數量後，要按一下「資料檔」中的「重填數量」按鈕，才能順利新增至「查詢」工作表中，
    我在自行研究一下關聯性，謝謝您的幫忙~~~

123.gif
VBAtest11.rar (19.48 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
44#
發表於 2012-12-19 12:49 | 只看該作者
本帖最後由 GBKEE 於 2012-12-19 12:54 編輯

回復 43# emma
****  程式碼 要吸收 才會進步  ***
Private Sub Worksheet_Change(ByVal Target As Range)  
是"資料檔"這工作表 的儲存格有修改後,會執行的程序(系統預設的工作表事件: Target ->有修改後的儲存格  )
  1. If Target.Address(0, 0) = "E1" Then
  2.         Range("D3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
  3.     ElseIf Target.Address(0, 0) = "C1" Then
  4.         Range("C3").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
  5.     Else
  6.         Exit Sub                                  '*****
  7.     End If
複製代碼
這巨集 設計為在 E1 或是 C1   有修改後,才會執行
你在B欄有修改後 程式會 Exit Sub    (離開程序 :不執行了)      達不到你的期望                         '*****
你要當B欄數量有輸入要傳送到[查詢] 裡 那會造成資料筆數的錯亂   所以才設計 Exit Sub
另一方法:
現在 請不要用Private Sub Worksheet_Change(ByVal Target As Range) (刪掉它)
再設一按鈕 指定執行巨集: 數量查詢
當你的E1 , C1 或是  B欄數量 修改完成後 確定按[按鈕]  傳送到[查詢]
  1. Sub 數量查詢()  '這程序需複製到 [資料檔]的模組中
  2.     Dim Target_Row As String, s As Integer, dot As Long, k As Integer, m As String
  3.     Dim Ar(), A As Range, Rng As Range
  4.     Range("D3").AutoFilter Field:=2, Criteria1:="*" & [C1] & "*"
  5.     Range("C3").AutoFilter Field:=1, Criteria1:="*" & [E1] & "*"
  6.     Set Rng = Sheets("資料檔").Range("B4:B65536").SpecialCells(xlCellTypeVisible)     '自動篩選後可見的儲存格
  7.     If Application.Count(Rng) > 0 Then                                                      '可見的儲存格:有資料儲存格的總數>0
  8.         Set Rng = Rng.SpecialCells(xlCellTypeConstants)                         '可見的儲存格:有資料的儲存格
  9.             For Each A In Rng.Cells
  10.                 ReDim Preserve Ar(s)
  11.                 If A.Offset(, 8) = "V" And A.Offset(, 9) >= Date And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  12.                 k = IIf(Sheets("查詢").[B1] = "總店", 10, 11)
  13.                 If A.Offset(, 7) < Date Then
  14.                     m = "已結束"
  15.                 ElseIf A < A.Offset(, 4) Then
  16.                     m = "運費+手續費"
  17.                 ElseIf InStr(A.Offset(, 5), "推") And A > A.Offset(, 4) Then       '包含
  18.                     m = "免運"
  19.                 ElseIf InStr(A.Offset(, 5), "推") = 0 And A > A.Offset(, 4) Then   '不包含
  20.                     m = "運費"
  21.                 End If
  22.                 Ar(s) = Array(A.Offset(, 2).Value, A.Value, A.Offset(, 3).Value, dot, A.Offset(, 12).Value, A.Offset(, k).Value, m, A.Offset(, 6).Value)
  23.                 s = s + 1
  24.             Next
  25.     End If
  26.     With Sheets("查詢")
  27.         If s > 0 Then
  28.             .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  29.             Sheets("資料檔").[C2] = .Range("A" & .Rows.Count).End(xlUp).Offset(, 5)   'F欄:儲位
  30.         End If
  31.     End With
  32. End Sub
複製代碼

TOP

emma

帖子
110 
主題
14 
精華
0 
積分
239 
點名
0  
作業系統
win xp 
軟體版本
office 2003 
閱讀權限
20 
性別
女 
註冊時間
2010-8-2 
最後登錄
2017-5-10 

有您真好勳章
45#
發表於 2012-12-19 13:15 | 只看該作者
回復 44# GBKEE

    GBKEE版大，真的非常的感謝您，我目前想要保有原有的功能再加上可以查詢出儲位，所以其實只要把儲位的那列
放進原本的程式中執行就可以了，只是我不曉得↓這句的語法要怎麼用才對，所以向您提問，另外，您所提供的各種方式，
我都想要試試，即便是現在不會採用，但如您所言，程式要多吸收才會進步，非常感謝您的解惑^^
  1. Sheets("資料檔").[C2] = .Range("A" & .Rows.Count).End(xlUp).Offset(, 5)
複製代碼
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim Target_Row As String, s As Integer, dot As Long, k As Integer, m As String
  4.     Dim Ar(), A As Range
  5.     If Target.Address(0, 0) = "E1" Then
  6.         Range("D3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
  7.     ElseIf Target.Address(0, 0) = "C1" Then
  8.         Range("C3").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
  9.     End If
  10.     With Sheet1
  11.         If Application.Count(.Range("B:B")) > 0 Then
  12.             For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants, 1)
  13.                 ReDim Preserve Ar(s)
  14.                 If A.Offset(, 8) = "V" And A.Offset(, 9) >= Date And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  15.                 k = IIf(Sheets("查詢").[B1] = "總店", 10, 11)
  16.                 If A.Offset(, 7) < Date Then
  17.                     m = "已結束"
  18.                 ElseIf A < A.Offset(, 4) Then
  19.                     m = "運費+手續費"
  20.                 ElseIf InStr(A.Offset(, 5), "推") And A > A.Offset(, 4) Then       '包含
  21.                     m = "免運"
  22.                 ElseIf InStr(A.Offset(, 5), "推") = 0 And A > A.Offset(, 4) Then   '不包含
  23.                     m = "運費"
  24.                 End If
  25.                 Ar(s) = Array(A.Offset(, 2).Value, A.Value, A.Offset(, 3).Value, dot, A.Offset(, 12).Value, A.Offset(, k).Value, m, A.Offset(, 6).Value)
  26.                 s = s + 1
  27.             Next
  28.         End If
  29.     End With
  30.     With Sheets("查詢")
  31.         If s > 0 Then
  32.             Target = ""
  33.             .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  34.             .Range("A4").CurrentRegion.Sort key1:=.[A4], Header:=xlYes
  35. [color=Red]             Sheets("資料檔").[C2] = .Range("A" & .Rows.Count).End(xlUp).Offset(, 5)   'F欄:儲位[/color]
  36.         End If
  37.     End With
  38. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
46#
發表於 2012-12-19 13:40 | 只看該作者
回復 45# emma
要保有原來的功能那 Private Sub Worksheet_Change(ByVal Target As Range)
這程序還是要依照42# 的程式碼 , 但需刪掉這09, 10 兩行的程式碼.(以前的程式會抓取B欄所有的數字資料)
  1. 09.    Else
  2. 10.        Exit Sub                                  '*****
複製代碼
  1. 13.    Set Rng = Range("B4:B65536").SpecialCells(xlCellTypeVisible)     '自動篩選後可見的儲存格
  2.        '13:抓取  C1 ,E1 自動篩選 的範圍
  3. 14.    If Application.Count(Rng) > 0 Then                                                      '可見的儲存格:有資料儲存格的總數>0
  4. 15.        Set Rng = Rng.SpecialCells(xlCellTypeConstants)                         '可見的儲存格:有資料的儲存格
複製代碼

TOP

emma

帖子
110 
主題
14 
精華
0 
積分
239 
點名
0  
作業系統
win xp 
軟體版本
office 2003 
閱讀權限
20 
性別
女 
註冊時間
2010-8-2 
最後登錄
2017-5-10 

有您真好勳章
47#
發表於 2012-12-19 15:27 | 只看該作者
回復 46# GBKEE

   GBKEE版大，初期兩個測試下來似乎沒有什麼不一樣，因為當輸入完數量後，B欄就會自動清空，不會留值在原儲存格上，
這樣的話，45#跟46#的差異是因為"以前的程式會抓取B欄所有的數字資料"，所以45#會有不確定因素導致判斷失常嗎?
看來我還有很多需要去吸收消化的，如不是您的提點，我不會察覺45#有什麼問題，謝謝您耐心的指導^^

PS.我是試著把「Target = ""」拿掉，那就真的差很多了~~不是很清楚為什麼45#把Target = ""拿掉會執行出這樣的結果
  1.   If s > 0 Then
  2.             Target = ""
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
48#
發表於 2012-12-19 16:34 | 只看該作者
回復 47# emma
對於觀看程式執行過程: 可在 VBA視窗中,將滑鼠點在程式碼的範圍內,按下F8 逐步執行
如同圖示:在工作表視窗中

TOP

emma

帖子
110 
主題
14 
精華
0 
積分
239 
點名
0  
作業系統
win xp 
軟體版本
office 2003 
閱讀權限
20 
性別
女 
註冊時間
2010-8-2 
最後登錄
2017-5-10 

有您真好勳章
49#
發表於 2012-12-26 15:05 | 只看該作者
回復 48# GBKEE

GBKEE版大，您好
想利用【查詢】工作表再彙整至【未出貨清單】的工作表，但不曉得該如何設定才好，所以又來向您請教，
如附件，【查詢】工作表中尾欄多了一欄【出貨狀況】的欄位，一般預設【出貨狀況】為「未出貨」，但在有現貨的狀況下，可由人員自行改為「已出貨」
需列印「未出貨明細」所以可否按「未出貨明細」的按鈕，將【出貨狀況】為「已出貨」及【活動狀態】為「已結束」的項目扣除後，
將其餘「未出貨」的合併至「未出貨清單」工作表中?結果如附件中【未出貨清單】的工作表的樣子(是我手動自己改成要呈現的結果)


    VBAtest12.rar (22.29 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
50#
發表於 2012-12-27 08:42 | 只看該作者
回復 49# emma
試試看


11.zip (31.37 KB)

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
1234567
返回列表 上一主題