emma

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

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

回復 12# GBKEE


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

下載 (13.11 KB)

2012-11-6 18:35

   

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

下載 (55.59 KB)

2012-11-6 18:48

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

下載次數: 8

2012-11-6 18:50

GBKEE

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

回復 14# GBKEE


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

softsadwind

回復 15# emma


感謝兩位，一位提供想法，一位提供方法...是蠻實用的技巧....多謝...

emma

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

複製代碼

下載 (107.54 KB)

2012-11-8 13:09

下載 (47.61 KB)

2012-11-8 13:09

下載 (41.48 KB)

2012-11-8 13:09

下載 (104.36 KB)

2012-11-8 13:09

VBA學習應用10111-03.rar (861.73 KB)

下載次數: 3

2012-11-8 13:31

麻煩您了，謝謝^^

GBKEE

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

回復 18# GBKEE


    GBKEE版大，謝謝您，已沒有出錯誤的訊息，再向您請教一下，清除按鈕的↓這段是不是無法清除因篩選而隱藏起來的儲存格
   如果要將被隱藏起來儲存格裡面的值一起清除，是要讓Sheet1把篩選的欄位都放開再執行清空嗎?謝謝您^^

1.     Sheet1.UsedRange.Range("B4:B60300").Clear

複製代碼

GBKEE

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