返回列表 上一主題 發帖

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

回復 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那列的位置嗎?

謝謝^^

TOP

回復 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
複製代碼

TOP

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

回復 12# GBKEE


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

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

附件 VBA學習應用10111-2.rar (854.53 KB)

TOP

回復 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
複製代碼

TOP

回復 14# GBKEE


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

TOP

回復 15# emma


感謝兩位,一位提供想法,一位提供方法...是蠻實用的技巧....多謝...
50 字節以內
不支持自定義 Discuz! 代碼

TOP

回復 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
複製代碼





VBA學習應用10111-03.rar (861.73 KB)
麻煩您了,謝謝^^

TOP

回復 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 是接收單一的值 **所以型態不同

TOP

回復 18# GBKEE


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

TOP

回復 19# emma
這問題你試試就知道

TOP

        靜思自在 : 好事要提得起,是非要放得下,成就別人即是成就自己。
返回列表 上一主題