標題: [發問] 如何貼上資料後，當資料重複，刪除到資料正確為止？ [打印本頁]

---

作者: av8d    時間: 2022-11-22 12:38     標題: 如何貼上資料後，當資料重複，刪除到資料正確為止？

[attach]35507[/attach]

先複製一串文字，打開文件，按一下B2，
會自動將複製的文字貼在下方，當貼上的文字與上一筆重複則會被清除，
照道理會持續到文字不重複才會繼續向下貼上，還請前輩們幫幫忙，謝謝！

---

作者: Andy2483    時間: 2022-11-22 14:52

本帖最後由 Andy2483 於 2022-11-22 15:05 編輯

回復 1# av8d


    謝謝前輩發表此主題與範例
用按鈕啟動巨集比較單純達到想要的情境結果
例如:
1.InputBox()
2.貼入複製的字串方式
3.達到目的


PS:
Worksheet_SelectionChange()容易有觸發再觸發的循環狀況

---

作者: singo1232001    時間: 2022-11-22 15:17

本帖最後由 singo1232001 於 2022-11-22 15:19 編輯

回復 1# av8d

---

作者: av8d    時間: 2022-11-22 15:36

回復 3# singo1232001

謝謝前輩，我曾成功過，但只限於指定儲存格，如附件
[attach]35510[/attach]

---

作者: av8d    時間: 2022-11-23 07:23

回復 2# Andy2483

謝謝前輩的大力幫忙，我才疏學淺，尚須努力，依然只能先能用再改寫，以下是完成品

[attach]35513[/attach]

---

作者: Andy2483    時間: 2022-11-23 09:52

回復 5# av8d


    恭喜前輩
後學有試成功:
[attach]35514[/attach]

後學有個想法:
防止觸發再觸發,不知道正不正確??
請前輩們指導!謝謝
1.前方加 Application.EnableEvents = False:觸發失效
2.後方加Application.EnableEvents = True:觸發啟動
3.Application.EnableEvents = True: Exit Sub:離開前觸發啟動

原程式碼添加如下:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
    If Left(Target.Address(0, 0), 1) = "A" Then
    ElseIf Left(Target.Address(0, 0), 1) = "B" Then
        If Cells(Target.Row, 2) = "貼上文號" Then
        [B1] = ""
            For i = 0 To 5000
                If Cells(3 + i, 2) = "" Then
                    Cells(3 + i, 2).Select
                    ActiveSheet.PasteSpecial xlPasteValues
                    [B1] = "完成"
                    '判斷是否重複複製
                    If Cells(3 + i, 2) = Cells(2 + i, 2) Then
                        [B1] = "重複複製"
                        Cells(3 + i, 2) = ""
                    End If
                    Application.EnableEvents = True: Exit Sub
                End If
            Next
        End If
    ElseIf Left(Target.Address(0, 0), 1) = "C" Then
        If Cells(Target.Row, 3) = "貼上名字" Then Application.EnableEvents = True: Exit Sub
        
    ElseIf Left(Target.Address(0, 0), 1) = "D" Then
        If Cells(Target.Row, 4) = "搜尋文號 ↑↑↑" Then [D1].Select
        
    ElseIf Left(Target.Address(0, 0), 1) = "E" Then
        If Cells(Target.Row, 5) = "複製文號" Then [D1].Select
        
    ElseIf Left(Target.Address(0, 0), 1) = "F" Then
        If Cells(Target.Row, 6) = "複製名字" Then [D1].Select
        
    ElseIf Left(Target.Address(0, 0), 1) = "G" Then
        If Cells(Target.Row, 7) = "搜尋名字 ↑↑↑" Then [G1].Select
    End If
Application.EnableEvents = True
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
    If Target.Address(0, 0) = "D1" Then
        If [D1] = "" Then ActiveSheet.Range("E2").AutoFilter Field:=1: Application.EnableEvents = True: Exit Sub
        [G1] = ""
        '搜尋文號
        Range("E2").AutoFilter Field:=1, Criteria1:="*" & Target & "*"
        ActiveWindow.ScrollRow = 1
   
    ElseIf Target.Address(0, 0) = "G1" Then
        If [G1] = "" Then ActiveSheet.Range("F2").AutoFilter Field:=2: Application.EnableEvents = True: Exit Sub
        [D1] = ""
        '搜尋名字
        Range("G2").AutoFilter Field:=2, Criteria1:="*" & Target & "*"
        ActiveWindow.ScrollRow = 1
    End If
Application.EnableEvents = True
End Sub

---

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