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

我有一个我认为会是一个简单的脚本，但我有一些奇怪的结果。
目标：使用 Translator 工作表上的ID列表标识 SOURCE 工作表中的特定ID。找到后，将整行复制到 OUTPUT 工作表。
输出结果很奇怪，我无法理解。

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

完整代码如下所示：
尝试：
1.我首先基于一个ID搜索 SOURCE 工作表，该ID被硬编码为一个简单的测试，它工作正常。但当我更改代码以搜索范围（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.我认为一个问题是Translator列表有重复项。其次，它正在搜索整个Z列。第二个问题可能是 Translator 中的列表是通过Z列中的公式生成的，因此，如果公式为假，它将在单元格中插入一个“”。我查找代码以避免粘贴单元格内容为“”或真正为空单元格的行。原因：当我们尝试将输出文件加载到下游系统时，“”将导致问题，因为它不是真正的空白单元格。

1.导致位置错误：脚本完成后，我的第一个结果没有按预期从第2行开始。我以为clear内容可以解决这个问题，但可能需要不同的clear函数？或者clear函数在错误的位置？下面的屏幕截图显示了它应该如何显示。它在相同的列中，但直到第21行才开始。enter image description here
1.缓慢的代码：我有一个命令，复制和粘贴的第一行从 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

尝试一下-使用“匹配”作为检查查找列表中是否包含某个值的快速方法。

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

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

1条答案

相关问题

热门标签

最新问答