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

Question

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

目标:使用Translator工作表上的id列表识别SOURCE工作表中的特定id。找到后，将整行复制到OUTPUT工作表。

输出有奇怪的结果，我无法理解。

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

完整代码如下:

尝试:

1. 我首先搜索了SOURCE表基于一个ID是硬编码为一个简单的测试，它工作了。但是当我修改代码来搜索一个范围(z21:z)时，发生了两件事:1，它以9的倍数返回源文件中的所有内容，如上所述，并且您可以想象，完成的时间从秒飙升到分钟。我想我错过了一个add'l部分的代码来识别范围??

旧代码:

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

• 1。我认为一个问题是翻译人员列表有重复。第二个问题可能是Translator中的列表是通过Z列中的公式生成的，因此如果公式为假，则会插入一个";进牢房。我寻求代码不粘贴那些行，其中单元格内容是"Or是一个真正的空白单元格。原因:"当我们试图将Output文件加载到下游系统时，会导致问题，因为它不是一个真正的空白单元格。

2. 导致错误的位置:当脚本完成时，我的第一个结果不像预期的那样从第2行开始。我认为明确的内容会解决这个问题，但也许需要一个不同的明确的功能?还是清晰的函数放错地方了?下面的截图显示了它应该如何显示。它在相同的列中，但直到第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