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

Question

我有一个我认为会很简单的脚本，但我有一些奇怪的结果。

目标：使用翻译表上的 ID 列表识别SOURCE表中的特定 ID。 找到后，将整行复制到OUTPUT 工作表。

output 有我无法弄清楚的奇怪结果。

• 返回所有结果而不是有限列表。 AND 结果是奇怪的分组。 （第一个结果在第 21 行，只有 9 行数据，下一组有 90 行数据，从第 210 行开始，然后是空白行，然后是 900 行数据，等等。
• 结果不从第 2 行开始。

完整代码如下：

尝试：

1. 我首先根据一个硬编码为简单测试的 ID 搜索了SOURCE工作表并且它起作用了。 但是当我更改代码以搜索范围 (z21:z) 时，发生了两件事：1，如上所述，它以 9 的倍数返回源文件中的所有内容，并且正如您可以想象的那样，完成时间从几秒开始猛增分钟。 我想我错过了一段代码来识别范围？

旧代码：

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

新代码：

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. 我认为一个问题是翻译列表有重复项。 其次，它正在搜索整个 Z 列。第二个问题可能是Translator中的列表是通过 Z 列中的公式生成的，因此如果公式为假，它将在单元格中插入一个“”。 我寻找代码以不粘贴单元格内容是“”或真正空白单元格的那些行。 原因：当我们尝试将 Output 文件加载到下游系统时，“”会导致问题，因为它不是真正的空白单元格。

2. 结果位置错误：脚本完成后，我的第一个结果没有按预期从第 2 行开始。 我认为清晰的内容可以解决这个问题，但也许需要一个不同的清晰的 function？ 或者清除 function 在错误的地方？ 下面的屏幕截图显示了它应该如何显示。 它在同一列中，但直到第 21 行才开始。在此处输入图像描述

3. 慢代码：我有一个命令将第一行从SOURCE复制并粘贴到OUTPUT 。 我的代码很麻烦。 必须有更简单的方法。 我正在执行此复制和粘贴操作，以防源文件将来添加新列。

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

谢谢你的帮助。

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

试试这个 - 使用 Match 作为检查查找列表中是否包含值的快速方法。

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