Question

我的编码技巧就像零，我想如果有人可以修改这段代码或为我制作一个完全不同的代码。

我使用此代码根据Sheet（Items）中找到的值将Sheet（Data）中的行复制到Sheet（Result）

Sub TestCopy()
Dim LastRow As Long
Dim i As Long, j As Long

With Worksheets("Data")
LastRow = .Cells(.Rows.count, "C").End(xlUp).Row
End With

MsgBox (LastRow)
With Worksheets("Result")
j = .Cells(.Rows.count, "C").End(xlUp).Row + 1
End With

For i = 1 To LastRow
With Worksheets("Data")
If .Cells(i, 3).Value = ThisWorkbook.Sheets("Items").Range("A1") Then
.Rows(i).Copy Destination:=Worksheets("Result").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub

但是这只会移动具有在单元格中找到的值的行＆＃34; A1＆＃34;。我需要的是根据A1，A2，A3 ......中的值移动行，直到有一个空单元格。

示例：

数据表看起来像这样：

Sub Locator Item    On-Hand LPN Serial
ABC AA010101    445-0744166 1   PLK123456   XX45684
ABC AA010102    445-0719738 2   PLK123457   XX45685
ABC AA010103    000-0000000 3   PLK123458   XX45686
ABC AA010104    445-0719738 4   PLK123459   XX45687
ABC AA010105    000-0000000 5   PLK123460   XX45688
ABC AA010106    445-0719738 6   PLK123461   XX45689
ABC AA010107    000-0000000 7   PLK123462   XX45690
ABC AA010108    445-0719738 8   PLK123463   XX45691
ABC AA010109    000-0000000 9   PLK123464   XX45692
DEF BB010101    445-0744166 10  PLK123465   XX45693
DEF BB010102    2181-K090-V001  11  PLK123466   XX45694
DEF BB010103    2181-K090-V001  12  PLK123467   XX45695
DEF BB010104    000-0000000 13  PLK123468   XX45696
DEF BB010105    445-0744166 14  PLK123469   XX45697
DEF BB010106    000-0000000 15  PLK123470   XX45698
DEF BB010107    445-0720880 16  PLK123471   XX45699
DEF BB010108    2181-K090-V001  17  PLK123472   XX45700
DEF BB010109    000-0000000 18  PLK123473   XX45701
GHI CC010101    000-0000000 19  PLK123474   XX45702
GHI CC010102    2181-K090-V001  20  PLK123475   XX45703
GHI CC010103    000-0000000 21  PLK123476   XX45704
GHI CC010104    000-0000000 22  PLK123477   XX45705
GHI CC010105    445-0744166 23  PLK123478   XX45706
GHI CC010106    445-0720880 24  PLK123479   XX45707
GHI CC010107    000-0000000 25  PLK123480   XX45708
GHI CC010108    2181-K090-V001  26  PLK123481   XX45709
GHI CC010109    000-0000000 27  PLK123482   XX45710
JKL DD010101    445-0744166 28  PLK123483   XX45711
JKL DD010102    000-0000000 29  PLK123484   XX45712
JKL DD010103    000-0000000 30  PLK123485   XX45713
JKL DD010104    445-0720880 31  PLK123486   XX45714
JKL DD010105    445-0744166 32  PLK123487   XX45715
JKL DD010106    000-0000000 33  PLK123488   XX45716
JKL DD010107    445-0720880 34  PLK123489   XX45717
JKL DD010108    445-0744166 35  PLK123490   XX45718
JKL DD010109    000-0000000 36  PLK123491   XX45719

项目表如下所示：

445-0719738
2181-K090-V001
445-0744166
445-0720880

Answer 1

AutoFilter method可以帮助您选择要查找的行，并将它们一起发送到结果工作表。

Sub TestCopy_jpd()
    Dim v As Long, vITMs() As Variant, rng As Range
    With Worksheets("Items")
        With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            For Each rng In .Cells
                ReDim Preserve vITMs(v)
                vITMs(v) = rng.Value2
                v = v + 1
            Next rng
        End With
    End With
    With Worksheets("Data")
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Cells(1, 1).CurrentRegion
            .AutoFilter field:=3, Criteria1:=vITMs, Operator:=xlFilterValues
            'step down one row off the header
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                'are there rows to copy?
                If CBool(Application.Subtotal(103, .Cells)) Then
                    'there are visiblke rows - copy and paste them
                    .Cells.Copy _
                        Destination:=Worksheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
End Sub

首先检查Items工作表，然后构造一个项目数组。这用作Range.AutoFilter Method中的条件。快速检查以查看是否有可复制的可见单元格，如果有，则复制和粘贴操作完成操作。

附录：

要解决原始问题，您需要检查数据工作表中的项目是否与项目工作表中列出的任何项目相匹配。

With Worksheets("Data")
    For i = 1 To LastRow
        If Not IsError(Application.Match(.Cells(i, 3).Value, ThisWorkbook.Sheets("Items").Columns(1), 0)) Then
            .Rows(i).Copy Destination:=Worksheets("Result").Range("A" & j)
            j = j + 1
        End If
    Next i
End With

逐行执行此操作会慢得多，但我想提供实现原始目标的正确方法。

根据Sheet（Items）中的值将Sheet（Data）中的行复制到Sheet（Result）（Excel 2016）

1 个答案: