Board logo

標題: [發問] 篩選?關鍵字?查詢? [打印本頁]
作者: emma    時間: 2012-11-1 13:47     標題: 篩選?關鍵字?查詢?

您好，如圖，如果想簡化自動篩選的步驟(選「自訂」再輸入要查詢的值等於「10058」，
如果是只要有包含100的話要條件再選擇「包含」的這些步驟省略)，直接在
B1的地方輸入要篩選或查詢的關鍵字，按ENTER或離開輸入的儲存格後，
可以執行出如下圖的結果，請問用何種方式製作最有效率

謝謝^^

[attach]12988[/attach]

[attach]12989[/attach]
作者: GBKEE    時間: 2012-11-1 15:01

回復 1# emma
只要有包含100的話要條件再選擇  這是字串的篩選方式
Zip Code欄 的資料是數字,要當字串用 須全部的數字前 ' 如 '10058 系統會將視為文字  ,才可以用字串的篩選方式/
試試看
Sheet1工作表 模組的程式碼
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     If Target.Address(0, 0) = "B1" Then
  4.         Range("A3").AutoFilter Field:=1, Criteria1:=Target & "*"
  5.     End If
  6. End Sub
複製代碼
作者: emma    時間: 2012-11-1 15:17

回復 2# GBKEE


    謝謝GBKEE版大，可以正常執行成功，但不是很理解程式的語法?
    ↓請問這句是什麼意思?
    Range("A3").AutoFilter Field:=1, Criteria1:=Target & "*"
作者: GBKEE    時間: 2012-11-1 15:29

回復 3# emma
AutoFilte: 自動篩選 可看vba的說明
作者: emma    時間: 2012-11-1 17:02

回復 4# GBKEE


    謝謝GBKEE版大，我會努力研究學習這些陌生的語法~"~，我可以再另外向您請教一個問題嗎? >///<
    請問使用者能點選某列後，將此列的欄位帶到Sheet2裡如下圖所示的位置中，
    點選的順序不重要，但是點過一次的那一列資料就無法在Sheet2出現重複的第二次(也就是每筆資料只能被新增唯一一次到Sheet2裡)
    按清除的按鈕後就會淨空Sheet2裡的值並返回到Sheet1的工作表中
    不曉的這樣的敘述有沒有不清楚的地方，謝謝指教^^


  [attach]12995[/attach]

  [attach]12996[/attach]

  [attach]12997[/attach]
作者: GBKEE    時間: 2012-11-1 18:03

回復 5# emma
試試看
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim Target_Row As String
  4.     If Target.Address(0, 0) = "D1" Then
  5.         Range("C3").AutoFilter Field:=3, Criteria1:="*" & Target & "*"
  6.     ElseIf Target.Address(0, 0) = "B1" Then
  7.         Range("A3").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
  8.     End If
  9. End Sub
  10. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  11.     Dim Target_Row As String, xi As Integer, xi_Row As String
  12.     If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), Target) Is Nothing Then
  13.         'Intersect物件
  14.         Target_Row = Join(Application.Transpose(Application.Transpose(Target.Resize(, 5))), ",")
  15.         'Join 函數:傳回一個字串，該字串是透過連結某個陣列中的多個子字串而建立的。
  16.         xi = 7
  17.         Do While Sheets("sheet2").Cells(xi, 1) <> ""
  18.            xi_Row = Join(Application.Transpose(Application.Transpose(Sheets("sheet2").Cells(xi, 1).Resize(, 5))), ",")
  19.            If xi_Row = Target_Row Then Exit Sub
  20.            xi = xi + 1
  21.         Loop
  22.         Sheets("sheet2").Cells(xi, 1).Resize(, 5) = Split(Target_Row, ",")
  23.         'Split 函數: 傳回一個陳列索引從零開始的一維陣列，它包含指定數目的子字串。
  24.     End If
  25. End Sub
複製代碼
作者: emma    時間: 2012-11-1 18:18

回復 6# GBKEE


    哇，真的沒想到可以做得出來這樣的效果，謝謝GBKEE版大，我要好好努力融會貫通一下，太開心了，非常的感謝您^^
作者: emma    時間: 2012-11-1 18:30

回復 6# GBKEE


    GBKEE版大，不好意思，我又想到另一個問題，如果帶到Sheet2中的不是連續的欄位呢?
    例如只有第一欄、第三欄、第五欄
    Zip Code        、Area、Scope
    要如何更改呢?

    麻煩您了，謝謝^^
作者: GBKEE    時間: 2012-11-2 18:14

回復 8# emma
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim Target_Row As String, xi As Integer, xi_Row As String
  3.     If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), Target) Is Nothing Then
  4.         'Intersect物件
  5.         Target_Row = 第一欄 & "," & 第三欄 & "," & 第五欄    '這裡自行修改 連接不連續位置
  6.         xi = 7
  7.         Do While Sheets("sheet2").Cells(xi, 1) <> ""
  8.            xi_Row = Join(Application.Transpose(Application.Transpose(Sheets("sheet2").Cells(xi, 1).Resize(, 3))), ",")
  9.            If xi_Row = Target_Row Then Exit Sub
  10.            xi = xi + 1
  11.         Loop
  12.         Sheets("sheet2").Cells(xi, 1).Resize(, 3) = Split(Target_Row, ",")
  13.         'Split 函數: 傳回一個陳列索引從零開始的一維陣列，它包含指定數目的子字串。
  14.     End If
  15. End Sub
複製代碼
作者: emma    時間: 2012-11-2 18:52

回復 9# GBKEE


    謝謝GBKEE版大的耐心指導，依您循循善誘的方試讓我自行找出我要的答案了，非常感謝您的用心^^
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim Target_Row As String, xi As Integer, xi_Row As String
  3.     If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), Target) Is Nothing Then
  4.        'Intersect物件
  5.         Target_Row = Target(, 1) & "," & Target(, 3) & "," & Target(, 5)    '這裡自行修改 連接不連續位置
  6.         xi = 7
  7.         Do While Sheets("sheet2").Cells(xi, 1) <> ""
  8.         xi_Row = Join(Application.Transpose(Application.Transpose(Sheets("sheet2").Cells(xi, 1).Resize(, 3))), ",")
  9.         If xi_Row = Target_Row Then Exit Sub
  10.            xi = xi + 1
  11.         Loop
  12.         Sheets("sheet2").Cells(xi, 1).Resize(, 3) = Split(Target_Row, ",")
  13.         'Split 函數: 傳回一個陳列索引從零開始的一維陣列，它包含指定數目的子字串。
  14.     End If
  15. End Sub
複製代碼
這樣執行出的是我想要的結果，應該沒錯吧?!
作者: emma    時間: 2012-11-6 11:38

回復 9# GBKEE

GBKEE版大您好

不好意思，想再向您請教一下，之前設條件是希望Sheet1→Sheet2的資料每一筆只能被建置一次不可重複建置，
現在如果想改成允許同一筆資料無限次數可以點一次A欄某儲存格就出現至Sheet2一次的話，該如何更改程式呢?
我原先以為是「If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), Target) Is Nothing Then」
這列的關係，但我把這行拿掉後，還是一筆只能出現一次，為什麼呢?

另外，如果使用者不小心點錯，或是點了之後想從Sheet2將某筆移除的話，可以嗎?移除的方式可以跟Sheet1一樣，
例如點選A8的儲存格，就將A8整列移除A9列遞補上A8那列的位置嗎?

謝謝^^
作者: GBKEE    時間: 2012-11-6 16:04

回復 11# emma
試試看
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)    '允許同一筆資料無限次數可以點一次A欄某儲存格就出現至Sheet2一次
  2.     Dim Target_Row As String
  3.     If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), Target) Is Nothing Then
  4.        'Intersect物件:  Target包含在Range("A4", Range("A4").End(xlDown))*** 才要執行 ***
  5.         Target_Row = Target(, 1) & "," & Target(, 3) & "," & Target(, 5)    '這裡自行修改 連接不連續位置
  6.        Sheets("sheet2").Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Split(Target_Row, ",")
  7.         'Split 函數: 傳回一個陳列索引從零開始的一維陣列，它包含指定數目的子字串。
  8.     End If
  9. End Sub
  10. Sub Ex()  '果使用者不小心點錯:剛剛點錯 或 刪全部
  11.     Dim Target_Row As String, xi As Integer
  12.     If Not Application.Intersect(Range("A4", Range("A4").End(xlDown)), ActiveCell) Is Nothing Then
  13.         Target_Row = ActiveCell & "," & ActiveCell(, 3) & "," & ActiveCell(, 5)    '這裡自行修改 連接不連續位置
  14.         With Sheets("sheet2")
  15.             xi = .Range("a" & Rows.Count).End(xlUp).Row
  16.             Do While xi > 7
  17.                 If .Cells(xi, 1) & "," & .Cells(xi, 2) & "," & .Cells(xi, 3) = Target_Row Then
  18.                     .Cells(xi, 1).Resize(, 3).Delete xlUp
  19.                     Exit Sub  '剛剛點錯 只刪一次  ***將此成行註解掉 可刪全部
  20.                 End If
  21.                 xi = xi - 1
  22.             Loop
  23.        End With
  24.     End If
  25. End Sub
複製代碼
作者: emma    時間: 2012-11-6 18:53

本帖最後由 emma 於 2012-11-6 18:55 編輯

回復 12# GBKEE


    謝謝GBKEE版主，經測試的結果
    1.允許同一筆資料無限次數可以點一次A欄某儲存格就出現至Sheet2一次，這部份雖然執行沒有問題，但是實際使用後卻覺得不好使用
       因為必需離開原儲存格位置之後，再重新點選才會出現至Sheet2一次，例如點了A8，但沒有離開A8的位置再點一次A8
       是沒辦法繼續新增到Sheet2的。
    2.Sub Ex()  '如果使用者不小心點錯:剛剛點錯 或 刪全部，這段就完全沒有反應，不曉得是我哪裡有疏乎掉的地方?
    會在Sheet2所點選的A欄某儲存格旁出現「!」畫面如下圖↓
    [attach]13052[/attach]
   

    然後，不好意思，我可以再改變一下使用的方式嗎?
    想改變方式是如果在Zip Code前面多一欄筆數，例如在A8輸入所想要的筆數3筆後離開A8，A6輸入所想要的筆數7筆後離開A6
    那Sheet2會出現3筆A8列的指定欄位、7筆A6列的指定欄位，回去Sheet1修改A8筆數5筆、修改A6筆數4筆，
    最後Sheet2就會改為5筆A8列及4筆A6列的指定欄位，這樣可行嗎?
    不好意思，不曉得能不能明確表達我的意思，大致最後想呈現結果畫面如下:dizzy:
   [attach]13054[/attach]

附件[attach]13055[/attach]
作者: GBKEE    時間: 2012-11-7 16:48

回復 13# emma
儲存格旁出現「!」                                                                                                         那是錯誤檢查的提示功能表,可察看工具->選項 ->錯誤檢查
Sub Ex()  '如果使用者不小心點錯:剛剛點錯 或 刪全部，這段就完全沒有反應， Ex() 這程式 不會 自動執行的.它不是工作表的觸動事件

  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)             '***它是工作表的觸動事件 ***
  3.     Dim Target_Row As String
  4.     If Target.Address(0, 0) = "D1" Then
  5.         Range("F3").AutoFilter Field:=6, Criteria1:="*" & Target & "*"
  6.     ElseIf Target.Address(0, 0) = "B1" Then
  7.         Range("B3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
  8.     ElseIf Not Application.Intersect(Range("b4", Range("b4").End(xlDown)).Offset(, -1), Target) Is Nothing Then
  9.         Target_Row = Target(, 2) & "," & Target(, 3) & "," & Target(, 4) & "," & Target(, 5) & "," & Target(, 6)
  10.         改變使用的方式 Target.Value, Target_Row
  11.     End If
  12. End Sub
  13. Private Sub 改變使用的方式(傳送次數 As Integer, 接收字串 As String)
  14.     Dim xi  As Integer, xi_次數 As Integer, xi_字串, Rng As Range
  15.     With Sheet2
  16.         xi = 7
  17.         Do While .Cells(xi, 1) <> ""
  18.             xi_字串 = Join(Application.Transpose(Application.Transpose(.Cells(xi, 1).Resize(, 5))), ",")
  19.             If xi_字串 = 接收字串 Then
  20.                 If xi_次數 < 傳送次數 Then
  21.                     xi_次數 = xi_次數 + 1
  22.                 ElseIf xi_次數 = 傳送次數 Then
  23.                     If Rng Is Nothing Then Set Rng = .Cells(xi, 1) Else Set Rng = Union(Rng, .Cells(xi, 1))
  24.                 End If
  25.             End If
  26.             xi = xi + 1
  27.         Loop
  28.         If xi_次數 < 傳送次數 Then
  29.             For xi = xi To xi + 傳送次數 - xi_次數 - 1
  30.                 .Cells(xi, 1).Resize(, 5) = Split(接收字串, ",")
  31.             Next
  32.             .Range("A6").CurrentRegion.Sort Key1:=.Range("A7"), Order1:=xlAscending, Key2:=.Range( _
  33.                         "B7"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
  34.                         :=False, Orientation:=xlTopToBottom, SortMethod:=xlStroke, DataOption1:= _
  35.                         xlSortNormal, DataOption2:=xlSortNormal
  36.         ElseIf Not Rng Is Nothing Then
  37.             Rng.EntireRow.Delete
  38.         End If
  39.     End With
  40. End Sub
複製代碼
作者: emma    時間: 2012-11-7 18:27

回復 14# GBKEE


    GBKEE版大，謝謝您，可以正常執行沒有問題，我在第一時間就看到您回復的文了，
    但試了老半天的原因是我想太多了，我以為您在給我出考題，
    要自行去尋找「改變使用的方式」、「傳送次數」、「接收字串」...等中文字部份的答案，
    於是就搞笑了@"@，最後直接貼上您的程式一字未改反而就正常了~"~
    我在自行好好研究一下，非常的感謝您^^
作者: softsadwind    時間: 2012-11-8 11:06

回復 15# emma


感謝兩位，一位提供想法，一位提供方法...是蠻實用的技巧....多謝...
作者: emma    時間: 2012-11-8 13:33

回復 14# GBKEE


    GBKEE版大您好，有一個地方想在向您請教一下，就是我在Sheet1插入一欄位於A欄的位置並隱藏，此欄預備為索引欄位用，
    但在使用過程中如未至Sheet2點選【清除】的按鈕前，功能一切正常，但點完按鈕後，就會有錯誤，
    試過幾個方式，但不明白為什麼會有這樣的錯誤，所以想再向您請教一下，
    問題很像是出現在Sheet1.UsedRange.Range("B4:B60300").Clear這段，是因為篩選的關係嗎?
  1. Sub 清除_Click()
  2.     Sheet2.UsedRange.Offset(1, 0).Clear
  3.     Sheet1.UsedRange.Range("B4:B60300").Clear  '這段如果拿掉的話，就不會有問題，但又希望使用者在用的時候B欄可以清除重新輸入想要的筆數
  4. End Sub
複製代碼
[attach]13070[/attach]
[attach]13071[/attach]
[attach]13072[/attach]
[attach]13073[/attach]

[attach]13075[/attach]
麻煩您了，謝謝^^
作者: GBKEE    時間: 2012-11-8 14:36

回復 17# emma
修改如下 Target的第一個Cells(1)
  1. Target_Row = Target(, 2) & "," & Target(, 3) & "," & Target(, 4) & "," & Target(, 5) & "," & Target(, 6)
  2. 改變使用的方式 Target.Cells(1).Value, Target_Row
複製代碼


因為Sheet1.UsedRange..Range("B4:B60300").Clear 的範圍 導致
Private Sub Worksheet_Change(ByVal Target As Range)     
傳回 Target<=>.Range("B4:B60300") 不是單一的儲存格

改變使用的方式  Target.Value 是接收單一的值 **所以型態不同
作者: emma    時間: 2012-11-8 15:08

回復 18# GBKEE


    GBKEE版大，謝謝您，已沒有出錯誤的訊息，再向您請教一下，清除按鈕的↓這段是不是無法清除因篩選而隱藏起來的儲存格
   如果要將被隱藏起來儲存格裡面的值一起清除，是要讓Sheet1把篩選的欄位都放開再執行清空嗎?謝謝您^^
  1.     Sheet1.UsedRange.Range("B4:B60300").Clear
複製代碼
作者: GBKEE    時間: 2012-11-8 16:53

回復 19# emma
這問題你試試就知道
作者: emma    時間: 2012-11-8 17:18

回復 20# GBKEE


    GBKEE版主，我已經有試過了(只是我是用手動的方式試)，所以才會這麼詢問，
   我想問的是，能用巨集寫手動去做的這些動作嗎?
    還是只能手動才能讓篩選的隱藏儲存格"全部"清空?操作手動動作的巨集是存在的嗎?謝謝^^

我手動的方式是將
Zip Code欄位的篩選改回「全部」
Scope   欄位的篩選改回「全部」
再到Sheet2點選「清除」的按鈕

↑可以用巨集省略這些步驟嗎?
指令是跟手動的步驟一樣嗎?
作者: emma    時間: 2012-11-8 18:07

回復 20# GBKEE


    謝謝GBKEE版主不厭其煩的回復我問的小問題，我剛剛已試出我要的答案了，非常感謝您的指導~~
  1. Sub 清除_Click()
  2.     Sheet2.UsedRange.Offset(1, 0).Clear
  3.     Sheet1.UsedRange.Range("B4:B60300").Clear
  4.     Sheet1.UsedRange.Range("C1").Clear
  5.     Sheet1.UsedRange.Range("E1").Clear
  6.     Sheet1.UsedRange.AutoFilter Field:=2
  7.     Sheet1.UsedRange.AutoFilter Field:=6
  8. End Sub
複製代碼
作者: emma    時間: 2012-11-9 18:59

回復 20# GBKEE


    GBKEE版大您好，想再向您請教一下，如果想將數量依使用者輸入的數量去新增至【查詢】工作表B欄裡，並帶出其他對應或計算出符合的欄位值，
詳如附件，請教該如何做呢?規則在【查詢】工作表中的欄位名稱有加入註解，謝謝您^^

目前附件【查詢】工作表中的欄位是希望可以最終顯示的結果

[attach]13083[/attach]
[attach]13084[/attach]

[attach]13087[/attach]
作者: emma    時間: 2012-11-15 13:57

回復 20# GBKEE


    GBKEE版主，不好思意，因為實在找不出錯誤的地方，可以勞動您大駕幫忙看一下哪裡有問題嗎?
    執行測試結果在輸入第一筆及第二筆資料是沒問題，但第三筆之後就會錯亂了，假設第一筆在商品F輸入數量後，第二筆的位置沒限制，但第三筆就一定要在商品F之前(例商品E)才會帶入   Sheet2，在商品F之後(例商品N)就帶不過去Sheet2，為什麼會這樣??
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)  '***它是工作表的觸動事件 ***
  3.     Dim Target_Row As String, xi As Integer, xi_Row As String
  4.     If Not Application.Intersect(Range("A2", Range("A2").End(xlDown)), Target) Is Nothing Then
  5.         'Intersect物件
  6.         Target_Row = Target(, 1) & "," & Target(, 2)
  7. 'Join 函數:傳回一個字串，該字串是透過連結某個陣列中的多個子字串而建立的。
  8.         xi = 5
  9.         Do While Sheets("sheet2").Cells(xi, 1) <> ""
  10.            xi_Row = Join(Application.Transpose(Application.Transpose(Sheets("sheet2").Cells(xi, 1).Resize(, 2))), ",")
  11.            If xi_Row = Target_Row Then Exit Sub
  12.            xi = xi + 1
  13.         Loop
  14.         Sheets("sheet2").Cells(xi, 1).Resize(, 2) = Split(Target_Row, ",")
  15.         'Split 函數: 傳回一個陳列索引從零開始的一維陣列，它包含指定數目的子字串。
  16.     End If
  17. End Sub
複製代碼
[attach]13143[/attach]
作者: GBKEE    時間: 2012-11-15 15:49

回復 24# emma
  1. If Not Application.Intersect(Range("A2", Range("A2").End(xlDown)), Target) Is Nothing Then
  2. '改成 B2 -[B2].End(xlDown) 間資料列向左位移一欄 (A欄)  
  3. If Not Application.Intersect(Range("B2", Range("B2").End(xlDown).Offset(, -1)), Target) Is Nothing Then
複製代碼
23#
圖1與圖2相對應的資料[宏全]為何會是2筆資料
累積點數,活動狀態 兩欄 是如何判斷!!
作者: emma    時間: 2012-11-15 16:57

回復 25# GBKEE


    GBKEE版大，謝謝您^^，test2已正常~~~
    「宏全」會有二筆是因為，宏全可以有多筆不同的「數量」，使用者每輸入一次就會帶一筆到【查詢】裡，這也是我研究test2的原因
     累積點數的判斷是產品有分為「有點數累積」跟「沒有點數累積」的所以才在資料檔中建一欄位為【點數累積】，【點數累積】欄位為「V」就是「有點數累積」，【點數累積】欄位為「X」就是沒有「沒有點數累積」，但又存在第二個判斷的條件，就是「有點數累積」的有期間限制，而且每一件產品的累積期間不同，其判斷條件就設在「點數累積結束」這個欄位，如未KEY上結束日期前(就是保留空值"")，才能計算累積點數，第三個條件就是累積點數是以1000為單位，小於1000就沒有累積，例如1000~1999算累積1000、2000~2999算累積2000，以此類推。
　　活動狀態是想要判斷運費是否要計算，在「資料檔」工作表中，【主推商品】欄位有「推」字的話，就可以免運，但前提是要數量有大於【基本量】欄位，如果沒有符合上述條件的話，就要加計運費，當【主推商品】欄位沒有「推」字的話，數量又小於【基本量】欄位時，除運費另計外還要再加特別處理的手續費，但是當今天(當下的日期，如101/11/15)的日期超過【最後預購日】時，就不用做這些判斷，直接顯示「已結束」，因為商品已無法下單了。

所以我還滿頭大的，不曉得這樣是否能傳達清楚，謝謝GBKEE版大的幫忙^^
作者: emma    時間: 2012-11-15 17:17

回復 25# GBKEE

對不起，更正一下 關於「活動狀態」的說明
     1.如果數量小於【基本量】就是要收取「運費」+「手續費」
     2.如果數量大於【基本量】但是【主推商品】欄位沒有「推」字的話，只要收取「運費」
     3.如果數量大於【基本量】但是【主推商品】欄位且有「推」字的話，就「免運」
     ps.當【最後預購日】(例101/11/15不含當天)，也就是今天的【最後預購日期】如果是101/11/14(含)之前的話，就直接顯示「已結束」


補充說明「累積點數」的判斷
1.【點數累積】欄位為「V」且【最後預購日】(例101/11/15含當天)，就計算累積點數，累積點數是以1000為單位，小於1000就沒有累積，例如1000~1999算累積1000、2000~2999算累積2000，以此類推。
2.如果沒有完全符合上述的條件，例如【點數累積】欄位為「V」且【最後預購日】為101/11/14(今天以前)、【點數累積】欄位為「X」、數量小於1000，這些的點數就不用去計算了。

　　謝謝GBKEE版大的幫忙^^
作者: Hsieh    時間: 2012-11-15 22:48

回復 27# emma
是不是這樣效果?
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim Ar(), A As Range
  3. If Target.Address <> "$B$1" Then Exit Sub
  4. If Application.CountA(Range([A5], Cells(Rows.Count, 1))) > 0 Then
  5.    For Each A In Range([A5], Cells(Rows.Count, 1).End(xlUp))
  6.       ReDim Preserve Ar(s)
  7.       Ar(s) = Application.Transpose(Application.Transpose(A.Resize(, 8)))
  8.       s = s + 1
  9.     Next
  10. End If
  11.    
  12. With Sheet1
  13. If Application.Count(.Range("B:B")) > 0 Then
  14.    For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants, 1)
  15.    ReDim Preserve Ar(s)
  16.    If A.Offset(, 8) = "V" And (A.Offset(, 9) > Date Or A.Offset(, 9) = "") And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  17.    k = IIf(Target = "總店", 10, 11)
  18.       If A < A.Offset(, 4) Then
  19.          m = "運費+手續費"
  20.          ElseIf A.Offset(, 5) = "推" And A > A.Offset(, 4) Then
  21.          m = "免運"
  22.          ElseIf A.Offset(, 5) <> "推" 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. If s > 0 Then [A5].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  31. Range("A4").CurrentRegion.Sort key1:=[A4], Header:=xlYes
  32. End Sub
複製代碼
[attach]13151[/attach]
作者: emma    時間: 2012-11-16 13:08

回復 28# Hsieh

是的，謝謝Hsieh版大，大致上是這樣的效果，但是初步使用我想如果有二個地方可以調整一下的話會更好
1.工作表有【分店】與【總店】共通查詢使用，但大部份使用的人員只會只查自己所在的點，所以如果是【總店】應該就會固定查詢【總店】
在【資料檔】輸入數量後必需至【查詢】再點選「店別」的欄位才會帶出資料，可以先依預設的「店別」直接帶出資料嗎?
而且只要切換一次「店別」就會將【資料檔】所有輸入數量的欄位再帶進【查詢】一次(如圖一至圖三)

2.活動狀態少了判斷【最後預購日】這個條件，如果今天的日期大於【最後預購日】就顯示「已結束」提醒使用者此筆商品無法被購買。

[attach]13159[/attach]
[attach]13160[/attach]
[attach]13161[/attach]
↓以此圖為例，除了【欣錩】以外，其他筆的活動狀況如果可以設為已結束的話就更好了。
[attach]13162[/attach]

當然，我也會自己努力試試怎麼完成自己想要的效果，謝謝Hsieh版大的幫忙^^
作者: emma    時間: 2012-11-16 18:39

回復 28# Hsieh

Hsieh版大，不好意思，恕小的愚笨，我試了一整天才試出關於活動狀態的部份而以，所以只好再求救一下，
此方法把程式寫在【查詢】的「店別」欄位裡，所以只有在變動到「店別」的欄位時才能更新到【查詢】的內容，
所以如果想讓使用者在【資料檔】一變更數量欄位時就可以更新至【查詢】工作表的話，應該要如何設定才好呢?
目前的工作表不是不能使用，但是使用上有二個問題
一是必需將【資料檔】裡的數量欄位先清除掉，重新只key入想新增的數量，再至【查詢】工作表選擇店別，就可以順利新增，
但如果沒有全部清除的話，資料會混在一起分不清「儲位」是哪個店別的「儲位」，希望您能明白我在敘述什麼，殘念的希望週末回來後，
能再有所精進，祝您週末愉快^^
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim Ar(), A As Range
  3. If Target.Address <> "$B$1" Then Exit Sub
  4. If Application.CountA(Range([A5], Cells(Rows.Count, 1))) > 0 Then
  5.    For Each A In Range([A5], Cells(Rows.Count, 1).End(xlUp))
  6.       ReDim Preserve Ar(s)
  7.       Ar(s) = Application.Transpose(Application.Transpose(A.Resize(, 8)))
  8.       s = s + 1
  9.     Next
  10. End If
  11.    
  12. With Sheet1
  13. If Application.Count(.Range("B:B")) > 0 Then
  14.    For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants, 1)
  15.    ReDim Preserve Ar(s)
  16.    If A.Offset(, 8) = "V" And (A.Offset(, 9) > Date Or A.Offset(, 9) = "") And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  17.    k = IIf(Target = "總店", 10, 11)
  18.       If A.Offset(, 7) >= Date Then
  19.       If A < A.Offset(, 4) Then
  20.          m = "運費+手續費"
  21.          ElseIf A.Offset(, 5) = "推" And A > A.Offset(, 4) Then
  22.          m = "免運"
  23.          ElseIf A.Offset(, 5) <> "推" And A > A.Offset(, 4) Then
  24.          m = "運費"
  25.       End If
  26.    Else
  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. End With
  34. If s > 0 Then [A5].Resize(s, 8) = Application.Transpose(Application.Transpose(Ar))
  35. Range("A4").CurrentRegion.Sort key1:=[A4], Header:=xlYes
  36. End Sub
複製代碼
作者: Hsieh    時間: 2012-11-17 21:43

回復 30# emma

我覺得妳的需求不像是查詢資料
比較像是把資料檔工作表B欄有數値的列
經過處理後寫入查詢工作表
試試附件
[attach]13186[/attach]
作者: emma    時間: 2012-11-20 13:43

回復 31# Hsieh


    非常感謝Hsieh版大、GBKEE版大，得二位高手的協助，我已綜合出我想要的版本了，
    Hsieh版大，其實我也只是照使用者想要的功能去研究，是希望使用者在輸入數量時，能簡化人員用人工判斷的條件，以減少人工判斷的錯誤，所以就...成了這樣的工作表了。

PS.我想要再請教一個問題，能不能讓使用者在輸入完數量，將該筆數量寫至【查詢】工作表，就立即清空該儲存格?例如在B3輸入完1234離開後，將B3列資料帶入【查詢】工作表裡，再立即將B3的儲存格清空!!有這種方法嗎?

附上最後完成的練習範本，或許版大們可以更理解我問PS.的方法用意
[attach]13206[/attach]
作者: cea    時間: 2012-11-20 14:39

謝謝分享
感覺好多要學的喔
大大們都太強了
作者: emma    時間: 2012-11-20 14:55

回復 31# Hsieh


    Hsieh版大，還有一個地方想順便請教一下，就是↓這個地方可不可以改成「包含」與「不包含」的用法?但我不知道不包含的語法是什麼，所以這麼試的結果當然是跟我說語法錯誤啦 ，謝謝您!!
  1. ElseIf A.Offset(, 5) = "推" And A > A.Offset(, 4) Then
  2.          m = "免運"
  3.          ElseIf A.Offset(, 5) <> "推" And A > A.Offset(, 4) Then
複製代碼
  1. ElseIf A.Offset(, 5) Like "*推*" And A > A.Offset(, 4) Then
  2.          m = "免運"
  3.          ElseIf A.Offset(, 5) Not Like "*推*" And A > A.Offset(, 4) Then
複製代碼
作者: GBKEE    時間: 2012-11-20 16:50

回復 34# 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
  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.         End If
  36.     End With
  37. End Sub
複製代碼
作者: emma    時間: 2012-11-22 18:54

回復 35# GBKEE


    GBKEE版大謝謝您，還有一個新的想法，但這一個功能的可能性不曉得能不能做到，如果使用者在數量的欄位KEY某個關鍵字，如KEY"0"或非數字例"ABC"這種代號的話，就另外跳出一個輸入數量的視窗，讓使用者KEY入數量，目的是為了某些特殊的情形要避開計算「免運」的部份，無論該項產品本身是否有符合「免運」的條件，只要用這個方式輸入數量的話，就是不去判斷免運的部份，只會有「已結束」、「運費」、「運費+手續費」這三種判斷而以。

希望能獲得解惑，謝謝!!
作者: emma    時間: 2012-12-18 14:41

回復 35# GBKEE


    GBKEE版大，不好意思，想再向您請教一下，如想讓「資料檔」工作表的C2顯示最後一筆使用者輸入的儲位，應該要怎麼做呢?
    我試了Sheets("資料檔").[C2] = A.Offset(, k).Value，但會顯示「沒有設定物件變數或with區塊變數」為什麼呢?
    麻煩您了，謝謝^^
[attach]13592[/attach]
作者: GBKEE    時間: 2012-12-18 15:26

回復 37# 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
  5.     Application.EnableEvents = False              '****
  6.     If Target.Address(0, 0) = "E1" Then
  7.         Range("D3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
  8.     ElseIf Target.Address(0, 0) = "C1" Then
  9.         Range("C3").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
  10.     Else
  11.         Exit Sub                                  '*****
  12.     End If
  13.     With Sheet1
  14.         If Application.Count(.Range("B:B")) > 0 Then
  15.             For Each A In .Range("B:B").SpecialCells(xlCellTypeConstants, 1)
  16.                 ReDim Preserve Ar(s)
  17.                 If A.Offset(, 8) = "V" And A.Offset(, 9) >= Date And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  18.                 k = IIf(Sheets("查詢").[B1] = "總店", 10, 11)
  19.                 If A.Offset(, 7) < Date Then
  20.                     m = "已結束"
  21.                 ElseIf A < A.Offset(, 4) Then
  22.                     m = "運費+手續費"
  23.                 ElseIf InStr(A.Offset(, 5), "推") And A > A.Offset(, 4) Then       '包含
  24.                     m = "免運"
  25.                 ElseIf InStr(A.Offset(, 5), "推") = 0 And A > A.Offset(, 4) Then   '不包含
  26.                     m = "運費"
  27.                 End If
  28.                 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)
  29.                 s = s + 1
  30.             Next
  31.         End If
  32.     End With
  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
複製代碼
作者: emma    時間: 2012-12-18 16:48

回復 38# GBKEE

  GBKEE版主，試了，但是沒反應，連原先的功能也不見了，怎麼會這樣呢??
    [attach]13597[/attach]
作者: GBKEE    時間: 2012-12-18 17:02

本帖最後由 GBKEE 於 2012-12-18 17:03 編輯

回復 39# emma
輸入: 信
到[查詢]看看
[attach]13598[/attach]
作者: emma    時間: 2012-12-18 17:30

回復 40# GBKEE


    GBKEE版主，只有第一筆可以，但之後的就又沒作用了耶，連篩選也動不了(如圖二)
   [attach]13599[/attach]
   [attach]13600[/attach]
作者: GBKEE    時間: 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
複製代碼
作者: emma    時間: 2012-12-19 11:57

回復 42# GBKEE


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

[attach]13604[/attach]
[attach]13605[/attach]
作者: GBKEE    時間: 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
複製代碼
作者: emma    時間: 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
複製代碼
作者: GBKEE    時間: 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)                         '可見的儲存格:有資料的儲存格
複製代碼
作者: emma    時間: 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 = ""
複製代碼
[attach]13609[/attach]
[attach]13610[/attach]
[attach]13607[/attach]
[attach]13608[/attach]
作者: GBKEE    時間: 2012-12-19 16:34

回復 47# emma
對於觀看程式執行過程: 可在 VBA視窗中,將滑鼠點在程式碼的範圍內,按下F8 逐步執行
如同圖示:在工作表視窗中


[attach]13612[/attach]
作者: emma    時間: 2012-12-26 15:05

回復 48# GBKEE

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


    [attach]13692[/attach]
作者: GBKEE    時間: 2012-12-27 08:42

回復 49# emma
試試看


[attach]13700[/attach]
作者: emma    時間: 2013-1-2 14:18

回復 50# GBKEE


    GBKEE版大，您好，想再向您請教一下，可否於開啟excel時，先設定一視窗跳出讓使用人選擇「店別」及「經辦」，設定完成之後，
    其店別的相關設定是為了取代現有的【查詢】工作表中的B1，然後想再多一工作表【當日訂單明細】，但還是無法自行修改成想要的結果，
    如【當日訂單明細-手動結果】的樣子，所以再厚顏上來請教，謝謝您^^

[attach]13756[/attach]
作者: GBKEE    時間: 2013-1-2 17:42

回復 51# emma
試試看

[attach]13759[/attach]
作者: emma    時間: 2013-4-22 15:39

回復 52# GBKEE


     GBKEE版大，您好，又有一個新的想法想請教您，如果說想要讓使用者輸入完一筆資料之後，就跳出視窗顯示部份訊息的話，
不曉得怎麼把相關的顯示結果帶到TextBox裡，謝謝您^^


[attach]14747[/attach]
[attach]14748[/attach]
作者: GBKEE    時間: 2013-4-22 17:28

回復 53# 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, t As String
  4.     Dim Ar(), A As Range, Rng As Range
  5.     If Target.Address(0, 0) = "E1" Then
  6.         Range("D3").AutoFilter Field:=4, Criteria1:="*" & Target & "*"
  7.     ElseIf Target.Address(0, 0) = "C1" Then
  8.         Range("C3").AutoFilter Field:=3, Criteria1:="*" & Target & "*"
  9.     End If
  10.     Application.EnableEvents = False              '****
  11.     Set Rng = Range("B4:B65536").SpecialCells(xlCellTypeVisible)     '自動篩選後可見的儲存格
  12.     If Application.Count(Rng) > 0 Then                                                      '可見的儲存格:有資料儲存格的總數>0
  13.         Set Rng = Rng.SpecialCells(xlCellTypeConstants)                         '可見的儲存格:有資料的儲存格
  14.             For Each A In Rng.Cells
  15.              ReDim Preserve Ar(s)
  16.                 If A.Offset(, 8) = "V" And A.Offset(, 9) >= Date And A > A.Offset(, 4) Then dot = Int(A / 1000) * 1000 Else dot = 0
  17.                 K = IIf(Sheets("查詢").[b1] = "總店", 10, 11)
  18.                 If A.Offset(, 7) < Date Then
  19.                     M = "已結束"
  20.                     t = "已出貨"
  21.                 ElseIf A < A.Offset(, 4) Then
  22.                     M = "運費+手續費"
  23.                     t = "未出貨"
  24.                 ElseIf InStr(A.Offset(, 5), "推") And A > A.Offset(, 4) Then       '包含
  25.                     M = "免運"
  26.                     t = "未出貨"
  27.                 ElseIf InStr(A.Offset(, 5), "推") = 0 And A > A.Offset(, 4) Then   '不包含
  28.                     M = "運費"
  29.                     t = "未出貨"
  30.                 End If
  31.                 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, A.Offset(, 7).Value, t)
  32.                 s = s + 1
  33.             Next
  34.             With UserForm2
  35.                 .TextBox1 = Ar(s - 1)(0)
  36.                 .TextBox2 = dot
  37.                 .TextBox3 = M
  38.                 .Show
  39.             End With
  40.         End If
  41.     With Sheets("查詢")
  42.         If s > 0 And UserForm2.Msg = False Then
  43.             Target = ""
  44.             .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(s, 10) = Application.Transpose(Application.Transpose(Ar))
  45.             .Range("A4").CurrentRegion.Sort Key1:=.[A4], Header:=xlYes
  46.              Sheets("資料檔").[C2] = .Range("A" & .Rows.Count).End(xlUp).Offset(, 5)   'F欄:儲位
  47.         End If
  48.     End With
  49.     Application.EnableEvents = True                 '*******
  50. End Sub
複製代碼
  1. Public Msg As Boolean   '按下 [取消] 的公用變數
  2. Private Sub CommandButton1_Click()
  3.     UserForm2.Hide
  4. End Sub
  5. 'UserForm2 須增加一CommandButton2  '取消按鈕
  6. Private Sub CommandButton2_Click()  
  7.     Msg = True                               ''按下 [取消] 按鈕為 True
  8.     UserForm2.Hide
  9. End Sub
  10. Private Sub UserForm_Activate()  'UserForm 顯示時
  11.       Msg = False                '取消 [取消]按鈕
  12. End Sub
複製代碼
作者: emma    時間: 2013-4-24 12:29

回復 54# GBKEE

    謝謝 GBKEE 版大，另外有個小問題想再請教一下，就是累積點數的表示方式.TextBox2可以顯示出,千分位的符號嗎?例「1,234,567,890] 這樣
    或者是說想顯示「1萬2仟3佰4拾5點」這種表示方式，可以嗎?
    [attach]14769[/attach]
作者: GBKEE    時間: 2013-4-26 15:47

回復 55# emma
  1.             With Cells(Rows.Count, Columns.Count)
  2.                 .Value = dot
  3.                 .NumberFormatLocal = "[DBNum1][$-404]G/通用格式" '小寫國字
  4.                 '.NumberFormatLocal = "[DBNum2][$-404]G/通用格式" '大寫國字
  5.                 '.NumberFormatLocal = "#,##0_);[紅色](#,##0)"     '千分位
  6.             End With
  7.             With UserForm2
  8.                 .TextBox1 = Ar(s - 1)(0)
  9.                 .TextBox2 = Cells(Rows.Count, Columns.Count).Text
  10.                 .TextBox3 = M
  11.                 .Show
  12.             End With
複製代碼
作者: emma    時間: 2013-4-30 12:59

回復 56# GBKEE

   非常謝謝 GBKEE 版大，真的幫了大忙了，關於「'.NumberFormatLocal = "[DBNum2][$-404]G/通用格式" '大寫國字」
   這個部份想再做更細一點的詢問，如果是1,234,567,890的話，以「"[DBNum3][$-404]G/通用格式"」套用後
   顯示結果為「１億２千３百４十５萬６千７百８十９」，但實際上，要一部份數字一部份國字的原因只是為了讓使用人員好讀取，
   不用一個個以個、拾、佰、仟、萬的數上去才得知總共是多少的點數，但可以只顯示國字到萬就好嗎?
   例「１億２千３百４十５萬６千７百８十９」→「１２,３４５萬６千７百８十９」
   ↑可以這樣嗎?謝謝您了^^
作者: GBKEE    時間: 2013-4-30 15:35

回復 57# emma
  1. Option Explicit
  2. Sub EX()
  3.     '１２,３４５萬６千７百８十
  4.     Dim Dot As Long, m As String
  5.     Dot = 123456789
  6.     m = "000萬0千0百0十0"
  7.     If Len(CStr(Dot)) = 1 Then m = "0"
  8.     If Len(CStr(Dot)) = 2 Then m = "0十0"
  9.     If Len(CStr(Dot)) = 3 Then m = "0百0十0"
  10.     If Len(CStr(Dot)) = 4 Then m = "0千0百0十0"
  11.     MsgBox Format(Dot, m)
  12. End Sub
複製代碼
作者: emma    時間: 2013-5-1 11:33

回復 56# GBKEE


    謝謝 GBKEE 版大，那如果只想抓，仟跟萬就好，例如「123,000」就只顯示「12萬3仟」，現在的是「12萬3仟0佰0拾0」，那些"0"有辦法省略嗎?
   如果不是用程式，而是一般的儲存格格式有辦法用函數之類的達到類似的設定嗎?還是就只能用vba去達到這種顯示效果?!
   真的非常感謝您不厭其煩的回覆我的小問題^^
作者: GBKEE    時間: 2013-5-1 17:41

回復 59# emma
  1. Option Explicit
  2. Sub EX()
  3.     '１２,３４５萬６千７百８十
  4.     Dim Dot As Long, m As String
  5.     Dot = Int(123456789 / 1000)
  6.     m = "0萬0千"
  7.     MsgBox Format(Dot, m)
  8. End Sub
複製代碼
作者: emma    時間: 2013-5-1 21:11

回復 60# GBKEE


     謝謝 GBKEE 版大，您的方式不完全是我想要的結果，我是用了最笨的方式繞了一大圈做出我要的結果
起先我是用「=SUBSTITUTE(A4,"0拾","")」這種方式，但run的時候一直出現sub相關字的錯誤，所以才改為Replace，
但不曉得 GBKEE 版大對我這樣的做法有無更好的建議，還有我為了比照顯示的結果，本來用
Sheets("工作表1").[B1] = t
Sheets("工作表1").[B2] = t1
↑這樣來對照不同的顯示結果，但不曉得為什麼這樣執行會有當掉的情形
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     '１２,３４５萬６千７百８十
  4.     Dim Dot As Long, m As String, t As String, t1 As String
  5.     m = "0萬0仟0佰0拾0"
  6.     Dot = Sheets("工作表1").[A1]
  7.     If Len(CStr(Dot)) = 1 Then m = "0"
  8.     If Len(CStr(Dot)) = 2 Then m = "0拾0"
  9.     If Len(CStr(Dot)) = 3 Then m = "0佰0拾0"
  10.     If Len(CStr(Dot)) = 4 Then m = "0仟0佰0拾0"
  11.     t = Format(Dot, m)
  12.    'Sheets("工作表1").[B1] = Format(Dot, m)
  13.     With Sheets("工作表1")
  14.     t1 = Replace(t, "拾0", "拾")
  15.     t1 = Replace(t1, "0拾0", "")
  16.     t1 = Replace(t1, "0拾", "")
  17.     t1 = Replace(t1, "0佰", "")
  18.     Sheets("工作表1").[A4] = t1
  19.     End With
  20. End Sub
複製代碼
[attach]14857[/attach]
作者: Hsieh    時間: 2013-5-2 00:14

回復 61# emma
[attach]14858[/attach]
  1. Function Read_Number(MyNum)
  2. n = Right(MyNum, 4)
  3. a = Array("拾", "百", "千")
  4. k = Len(n)
  5. i = k
  6. Do Until i = 0
  7.   If Val(Mid(n, i, 1)) > 0 And i < k Then
  8.      m = Mid(n, i, 1) & a(j): j = j + 1
  9.      ElseIf i = k Then
  10.      m = IIf(Val(Mid(n, i, 1)) = 0, "", Mid(n, i, 1))
  11.      Else
  12.      m = IIf(Val(Mid(n, i, 1)) = 0, "零", Mid(n, i, 1) & a(j))
  13.      j = j + 1
  14.   End If
  15.   t = m & t
  16.   i = i - 1
  17. Loop
  18. For i = 3 To 2 Step -1
  19.   t = Replace(t, String(i, "零"), "零")
  20. Next
  21. s = Val(Left(MyNum, Len(MyNum) - k))
  22. Read_Number = IIf(s = 0, "", Format(Val(Left(MyNum, Len(MyNum) - k)), "#,##0萬")) & t
  23. End Function
複製代碼
作者: GBKEE    時間: 2013-5-2 06:47

回復 61# emma
  1. Option Explicit
  2. Private Sub Ex()
  3.     '１２,３４５萬６千７百８十
  4.     Dim Dot As Long, m As String, t As String, i  As Integer
  5.     m = "0萬0仟0佰0拾0 "         '加上一空格:處理個位數為0
  6.     Dot = Sheets("工作表1").[A1]
  7.     t = Format(Dot, m)
  8.     For i = IIf(Len(t) > 10, 3, 1) To Len(m) Step 2
  9.         'IIf(Len(t) > 10, 3, 1) 處理萬位數為0
  10.         t = Replace(t, Mid(m, i, 2), "")
  11.     Next
  12.     Sheets("工作表1").[A4] = t
  13.     'Sheets("工作表1").[A4] = RTrim(t)
  14.     'LTrim、RTrim 與 Trim 函數
  15.     '傳回一個沒有前頭空白 (LTrim)、後面空白 (RTrim) 或前後均無空白的Variant (String)，
  16. End Sub
複製代碼
作者: emma    時間: 2016-5-17 19:31

各位前輩們好，因為當初這個檔案設計的時間已久，加上很多程式是依賴各位大大們協助完成的，所以有功能想要做新的異動，但想很久都試不出來，只好再厚著臉皮上來求助

附件中的『未出貨清單』工作表是從『查詢』工作表中的資料彙整過去的，以前是把同「活動狀態」及「品名」的筆數整合在同一列上，
現在想要每一筆都列出來，相同的資料如果大於二筆，就多一列小計幫忙計算筆數，最後總筆數是全部的加總。
不曉得是否能這麼設定，麻煩大大們了，謝謝^^


[attach]24301[/attach]



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)