返回列表 上一主題 發帖

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

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

1.rar (387.2 KB)

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

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

回復 1# av8d


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


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

TOP

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

回復 1# av8d

1 v1.zip (462.13 KB)

TOP

回復 3# singo1232001

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

TOP

回復 2# Andy2483

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

3.rar (386.9 KB)

TOP

回復 5# av8d


    恭喜前輩
後學有試成功:
2022-11-23_094110.JPG
5 天前 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

TOP

        靜思自在 : 自己害自己,莫過於亂發脾氣。
返回列表 上一主題