VBA 如果单元格与 ID 列表匹配，则复制并粘贴整行，但如果列表包含空白单元格或带有“”的单元格，则不要粘贴

Question

I have what I thought would be a simple script, but I have some some strange results.

Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.

The output has strange results that I can't figure out.

• Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
• Results do not start in row 2.

Full code is below attempts:

Attempts:

1. I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??

Old Code:

For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If

New code:

For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If

• 1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.

2. Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21. enter image description here

3. Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT . My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.

 Worksheets("Output").Cells.ClearContents Sheets("SOURCE").Select Rows("1:1").Select Selection.Copy Sheets("Output").Select Rows("1:1").Select ActiveSheet.Paste

Thank you for all your help.

Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If   
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
 Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
 ActiveSheet.Paste
 Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
 Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
 For K = 1 To xRg.Count
 If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
  J = J + 1
 End If
 Next
Application.ScreenUpdating = True
End Sub

Answer 1

Try this out - using Match as a fast way to check if a value is contained in your lookup list.

Sub MoveRowBasedOnCellValuefromlist()
    Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
    Dim cDest As Range, wsTrans As Worksheet, rngList As Range
   
    Set wb = ThisWorkbook 'for example
    Set wsSrc = wb.Worksheets("SOURCE")
    Set wsOut = wb.Worksheets("Output")
    
    Set wsTrans = wb.Worksheets("Translator")
    Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
    
    ClearSheet wsOut
    wsSrc.Rows(1).Copy wsOut.Rows(1)
    Set cDest = wsOut.Range("A2")  'first paste destination
    
    Application.ScreenUpdating = False
    For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
        If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
            c.EntireRow.Copy cDest
            Set cDest = cDest.Offset(1) 'next paste row
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

'clear a worksheet
Sub ClearSheet(ws As Worksheet)
    With ws.Cells
        .ClearContents
        .ClearFormats
    End With
End Sub