[發問] 如何貼上資料後，當資料重複，刪除到資料正確為止？

av8d

1.rar (387.2 KB)

下載次數: 5

2022-11-22 12:35

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

Andy2483

回復 1# av8d


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


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

singo1232001

回復 1# av8d

av8d

回復 3# singo1232001

謝謝前輩，我曾成功過，但只限於指定儲存格，如附件
2.rar (386.8 KB)

下載次數: 4

2022-11-22 15:36

av8d

回復 2# Andy2483

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

3.rar (386.9 KB)

下載次數: 5

2022-11-23 07:23

Andy2483

回復 5# av8d


    恭喜前輩
後學有試成功:

下載 (28.74 KB)

2022-11-23 09:42

後學有個想法:
防止觸發再觸發,不知道正不正確??
請前輩們指導!謝謝
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