VBA跨工作表提取唯一值仅粘贴值报错1004求助

Hey there, sorry you're hitting that frustrating 1004 error—those can be tricky, but let's break this down and get it sorted. The most common culprits for this error with PasteSpecial are either not properly initiating a copy operation before calling it, or trying to paste into an invalid range (like merged cells, a protected sheet, or a range that doesn't match the copied data's dimensions).

But honestly, using Copy + PasteSpecial isn't the most efficient way to transfer values anyway—let's cover both a fix for your existing approach and a better alternative that avoids copy-paste entirely.

Solution 1: Fix the PasteSpecial Usage #

If you want to stick with your current workflow, make sure you're calling Copy first, then PasteSpecial on the destination range, and clear the copy mode afterward. Here's how to adjust your code snippet:

Option Explicit
Sub Uniquevalues()
    Dim lastrow As Long
    Dim wk As Worksheet
    Dim targetWs As Worksheet
    
    ' Set your source and target worksheets (adjust names as needed)
    Set wk = ThisWorkbook.Worksheets("SourceSheet")
    Set targetWs = ThisWorkbook.Worksheets("TargetSheet")
    
    ' Get last row with data in source sheet
    lastrow = wk.Cells(wk.Rows.Count, "A").End(xlUp).Row
    
    ' Copy the unique values range (assuming you've already filtered/removed duplicates)
    wk.Range("A1:A" & lastrow).Copy
    
    ' Paste only values to target sheet (starting at A1)
    On Error Resume Next ' Optional: Catch errors if range is invalid
    targetWs.Range("A1").PasteSpecial Paste:=xlPasteValues
    On Error GoTo 0
    
    ' Clear the clipboard to avoid the "marching ants"
    Application.CutCopyMode = False
End Sub

If you still get the 1004 error here, check these common issues:

• Is the target sheet protected? Unprotect it first if needed.
• Are you trying to paste into merged cells? Avoid those or adjust your target range.
• Is the source range empty? Add a check to skip copying if there's no data.

Solution 2: Transfer Values Directly (Better & Faster) #

A cleaner, faster approach that avoids copy-paste entirely is to assign the values directly from the source range to the target range. This skips formatting entirely and is more efficient for large datasets. Here's how to do it:

Option Explicit
Sub Uniquevalues_ValuesOnly()
    Dim lastrow As Long
    Dim wk As Worksheet
    Dim targetWs As Worksheet
    Dim sourceRange As Range
    
    Set wk = ThisWorkbook.Worksheets("SourceSheet")
    Set targetWs = ThisWorkbook.Worksheets("TargetSheet")
    
    lastrow = wk.Cells(wk.Rows.Count, "A").End(xlUp).Row
    Set sourceRange = wk.Range("A1:A" & lastrow)
    
    ' Remove duplicates from source range first (adjust Header as needed)
    sourceRange.RemoveDuplicates Columns:=1, Header:=xlYes
    
    ' Assign values directly to target range
    targetWs.Range("A1").Resize(sourceRange.Rows.Count, sourceRange.Columns.Count).Value = sourceRange.Value
End Sub

Bonus: Use a Dictionary for Unique Values (Most Robust) #

If you want to avoid modifying the source sheet's data (since RemoveDuplicates alters the original), use a Dictionary to collect unique values and write them to the target sheet. This keeps your source data intact and gives you full control over which values are included:

Option Explicit
Sub Uniquevalues_Dictionary()
    Dim lastrow As Long
    Dim wk As Worksheet
    Dim targetWs As Worksheet
    Dim cell As Range
    Dim uniqueDict As Object
    
    Set wk = ThisWorkbook.Worksheets("SourceSheet")
    Set targetWs = ThisWorkbook.Worksheets("TargetSheet")
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    lastrow = wk.Cells(wk.Rows.Count, "A").End(xlUp).Row
    
    ' Collect unique values (skip header if needed)
    For Each cell In wk.Range("A2:A" & lastrow)
        If Not cell.Value = "" And Not uniqueDict.Exists(cell.Value) Then
            uniqueDict.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' Write unique values to target sheet
    If uniqueDict.Count > 0 Then
        targetWs.Range("A2").Resize(uniqueDict.Count).Value = Application.Transpose(uniqueDict.Keys)
        ' Add header if needed
        targetWs.Range("A1").Value = "Unique Values"
    End If
End Sub

内容的提问来源于stack exchange，提问作者alex2002