篩選?關鍵字?查詢? - Excel程式區

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

有您真好勳章

11^# 跳轉到 »

發表於 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那列的位置嗎?

謝謝^^

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

12^#

發表於 2012-11-6 16:04 | 只看該作者

回復 11# emma
試試看

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

複製代碼

TOP

emma

中學生 Rank: 2

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

有您真好勳章

13^#

發表於 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欄某儲存格旁出現「!」畫面如下圖↓

然後，不好意思，我可以再改變一下使用的方式嗎?
想改變方式是如果在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

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

14^#

發表於 2012-11-7 16:48 | 只看該作者

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

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) '***它是工作表的觸動事件 ***
Dim Target_Row As String
If Target.Address(0, 0) = "D1" Then
Range("F3").AutoFilter Field:=6, Criteria1:="*" & Target & "*"
ElseIf Target.Address(0, 0) = "B1" Then
Range("B3").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
ElseIf Not Application.Intersect(Range("b4", Range("b4").End(xlDown)).Offset(, -1), Target) Is Nothing Then
Target_Row = Target(, 2) & "," & Target(, 3) & "," & Target(, 4) & "," & Target(, 5) & "," & Target(, 6)
改變使用的方式 Target.Value, Target_Row
End If
End Sub
Private Sub 改變使用的方式(傳送次數 As Integer, 接收字串 As String)
Dim xi As Integer, xi_次數 As Integer, xi_字串, Rng As Range
With Sheet2
xi = 7
Do While .Cells(xi, 1) <> ""
xi_字串 = Join(Application.Transpose(Application.Transpose(.Cells(xi, 1).Resize(, 5))), ",")
If xi_字串 = 接收字串 Then
If xi_次數 < 傳送次數 Then
xi_次數 = xi_次數 + 1
ElseIf xi_次數 = 傳送次數 Then
If Rng Is Nothing Then Set Rng = .Cells(xi, 1) Else Set Rng = Union(Rng, .Cells(xi, 1))
End If
End If
xi = xi + 1
Loop
If xi_次數 < 傳送次數 Then
For xi = xi To xi + 傳送次數 - xi_次數 - 1
.Cells(xi, 1).Resize(, 5) = Split(接收字串, ",")
Next
.Range("A6").CurrentRegion.Sort Key1:=.Range("A7"), Order1:=xlAscending, Key2:=.Range( _
"B7"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlStroke, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal
ElseIf Not Rng Is Nothing Then
Rng.EntireRow.Delete
End If
End With
End Sub

複製代碼

TOP

emma

中學生 Rank: 2

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

有您真好勳章

15^#

發表於 2012-11-7 18:27 | 只看該作者

回復 14# GBKEE

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

TOP

softsadwind

中學生 Rank: 2

帖子: 129
主題: 3
精華: 0
積分: 178
點名: 0
作業系統: XP
軟體版本: 2010
閱讀權限: 20
性別: 男
註冊時間: 2010-12-28
最後登錄: 2018-11-10

16^#

發表於 2012-11-8 11:06 | 只看該作者

回復 15# emma

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

50 字節以內
不支持自定義 Discuz! 代碼

TOP

emma

中學生 Rank: 2

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

有您真好勳章

17^#

發表於 2012-11-8 13:33 | 只看該作者

回復 14# GBKEE

GBKEE版大您好，有一個地方想在向您請教一下，就是我在Sheet1插入一欄位於A欄的位置並隱藏，此欄預備為索引欄位用，
但在使用過程中如未至Sheet2點選【清除】的按鈕前，功能一切正常，但點完按鈕後，就會有錯誤，
試過幾個方式，但不明白為什麼會有這樣的錯誤，所以想再向您請教一下，
問題很像是出現在Sheet1.UsedRange.Range("B4:B60300").Clear這段，是因為篩選的關係嗎?

Sub 清除_Click()
Sheet2.UsedRange.Offset(1, 0).Clear
Sheet1.UsedRange.Range("B4:B60300").Clear '這段如果拿掉的話，就不會有問題，但又希望使用者在用的時候B欄可以清除重新輸入想要的筆數
End Sub

複製代碼

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

18^#

發表於 2012-11-8 14:36 | 只看該作者

回復 17# emma
修改如下 Target的第一個Cells(1)

Target_Row = Target(, 2) & "," & Target(, 3) & "," & Target(, 4) & "," & Target(, 5) & "," & Target(, 6)
改變使用的方式 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

emma