如果条件满足，Excel VBA 将数据复制到表中

Question

I've created the following code, which in theory should copy certain cells from the active worksheet into a worksheet name "checklist - audit". "Checklist-audit" contains a table and I only want it to copy and past if the value "KPI_Month" is already present in column A.

Please see code below:

SheetName = ActiveSheet.Select

KPI_Month = ActiveSheet.Range("N2").Value
KPI_QC_Score = ActiveSheet.Range("I10").Value
KPI_Score_Difference = ActiveSheet.Range("P1").Value
KPI_QC = ActiveSheet.Range("N11").Value
KPI_QC_Role = ActiveSheet.Range("N12").Value
KPI_Date_Stamp = Now()

Sheets("Checklist - Audit").Activate

lrow = Range("A1100").End(xlUp).Row + 1

Cells(lrow, 1).Activate

If Cells(lrow, 1) = KPI_Month Then

Cells(lrow, 5) = KPI_QC_Score
Cells(lrow, 6) = KPI_Score_Difference
Cells(lrow, 9) = KPI_QC
Cells(lrow, 10) = KPI_QC_Role
Cells(lrow, 11) = KPI_Date_Stamp

Else

MsgBox "Reviewer must submit first"


End If

My problem is that instead of copying and pasting it is automatically bringing up the message box. Also, if it is to copy and paste, it should do so on the same row as where the month has been found.

Could someone please explain where the code is going wrong and direct me to a solution.

Many thanks in advance.

Answer 1

I really hope i got your intentions fully and I will assume that you have two sheets involved here.

Sub test()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim foundRange As Range
    Dim lastRow As Long
    
    Set wsSource = ThisWorkbook.Sheets(1) 'or name of the sheet from where info is copied
    Set wsDest = ThisWorkbook.Sheets("Checklist - Audit")
    
    KPI_Month = wsSource.Range("N2").Value
    KPI_QC_Score = wsSource.Range("I10").Value
    KPI_Score_Difference = wsSource.Range("P1").Value
    KPI_QC = wsSource.Range("N11").Value
    KPI_QC_Role = wsSource.Range("N12").Value
    KPI_Date_Stamp = Now()
    
    lastRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    Set foundRange = wsDest.Range("A1:A1100").Find(What:=KPI_Month, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

        If Not foundRange Is Nothing Then
            wsDest.Cells(lastRow, 5) = KPI_QC_Score
            wsDest.Cells(lastRow, 6) = KPI_Score_Difference
            wsDest.Cells(lastRow, 9) = KPI_QC
            wsDest.Cells(lastRow, 10) = KPI_QC_Role
            wsDest.Cells(lastRow, 11) = KPI_Date_Stamp
        Else
            MsgBox "Reviewer must submit first"
        End If
End Sub