Pasting issues using VBA-CodePudding

wish you all the best.

I am making a code using VBA to find and detect errors from one sheet and paste the values from column A and B from the row of the error to the destination sheet. my code is mostly working my issue is the content that is pasting which is the error cell and the next one to the right instead of the values from A and B (example: imagine macro is running all values in column K and there is an error in K85, it is pasting K85 and L85, instead of A85 and B85)

Sub Copy_NA_Values()

Dim rng As Range
Dim firstBlank As Range
Dim shtSource As Worksheet
Dim shtDestination As Worksheet

Set shtSource = ThisWorkbook.Sheets("JE Royalty detail") 'Change to the name of the source sheet
Set shtDestination = ThisWorkbook.Sheets("DB") 'Change to the name of the destination sheet

Set rng = shtSource.Range("F:F").SpecialCells(xlCellTypeFormulas, xlErrors)

For Each cell In rng
    If IsError(Range("F:F")) = False Then
        Set firstBlank = shtDestination.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
        cell.Resize(1, 2).Copy firstBlank
    End If
Next cell

End Sub

How can I make it so it will paste the correct cells i have tried to use paste special but I might've used it wrongly but I had errors, all help apreciated.

Have a good one.

CodePudding user response：

it is pasting K85 and L85, instead of A85 and B85

Try replacing:

cell.Resize(1, 2).Copy firstBlank

with

shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy firstBlank

To paste only values, do this instead:

shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy
firstBlank.PasteSpecial (xlPasteValues)

CodePudding user response：

Copy Values When Matching Error Values

Option Explicit

Sub BackupErrorValues()
    
    Const SRC_NAME As String = "JE Royalty detail"
    Const SRC_ERROR_RANGE As String = "F:F"
    Const SRC_COPY_RANGE As String = "A:B"
    Const DST_NAME As String = "DB"
    Const DST_FIRST_CELL  As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim srg As Range
    On Error Resume Next ' to prevent error if no error values
        Set srg = Intersect(sws.UsedRange, sws.Columns(SRC_ERROR_RANGE)) _
            .SpecialCells(xlCellTypeFormulas, xlErrors)
    On Error GoTo 0
        
    If srg Is Nothing Then
        MsgBox "No cells with error values found.", vbExclamation
        Exit Sub
    End If
    
    Set srg = Intersect(srg.EntireRow, sws.Range(SRC_COPY_RANGE))
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    If dws.FilterMode Then dws.ShowAllData ' prevent failure of 'Find' method
    
    Dim dCell As Range
    With dws.UsedRange
        Set dCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    End With
    If dCell Is Nothing Then
        Set dCell = dws.Range(DST_FIRST_CELL)
    Else
        Set dCell = dws.Cells(dCell.Row   1, dws.Range(DST_FIRST_CELL).Column)
    End If
    
    Dim drrg As Range: Set drrg = dCell.Resize(, cCount)
    
    Dim sarg As Range, srCount As Long
    
    For Each sarg In srg.Areas
        srCount = sarg.Rows.Count
        drrg.Resize(srCount).Value = sarg.Value
        Set drrg = drrg.Offset(srCount)
    Next sarg
    
    MsgBox "Error rows backed up.", vbInformation

End Sub