Question

我是编写宏并尝试编写一个用于工作的新手。下面是我一直在争夺的一段代码。我希望它查看工作表“NG304”并找到列B中列出的关键词。如果关键词在那里，请将它们移动到第二个电子表格“工资单详细信息”。我遇到的问题 - 代码没有通过整个列表，它似乎没有粘贴在工资单细节电子表格的下一个可用行中（它只是粘贴在我的标题之上）。

代码：

Dim Findme As String, Findwhat As String, c As Range

With ActiveWorkbook.Worksheets("NG304")

        For Each c In .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
            Findwhat = vbNullString
            Findme = StrConv(c.Value2, vbProperCase)
            Select Case True
                Case Findme Like "VCIP"
                    Findwhat = "VCIP"
                Case Findme Like "Company Labor"
                    Findwhat = UCase(Findme)
                Case Else
                    'do nothing
            End Select

       If CBool(Len(Findwhat)) Then
                With .Parent.Worksheets("NG304")
                    c.EntireRow.Cut Destination:=Worksheets("Payroll Detail").Range("A" & lastrow + 1)
            lastrow = lastrow + 1
                End With
            End If
        Next c


    End With

Answer 1

这将过滤K_WORDS中定义的每个值（在顶部），并将行移动到另一个表：

Option Explicit

Public Sub moveKeywordRows()
    Const K_WORDS  As String = "VCIP,Company Labor"      '<------- Defined keywords

    Dim wsFrom As Worksheet, wsDest As Worksheet, kw As Variant, i As Long, lr As Long

    Set wsFrom = ThisWorkbook.Worksheets("NG304")
    Set wsDest = ThisWorkbook.Worksheets("Payroll Detail")
    kw = Split(K_WORDS, ",")

    Application.ScreenUpdating = False
    For i = 0 To UBound(kw)
        lr = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row
        With wsFrom.UsedRange
            .AutoFilter Field:=2, Criteria1:="=" & kw(i)
            .Copy
            wsDest.Cells(lr, "A").PasteSpecial xlPasteAll
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        Application.CutCopyMode = False
        wsDest.Activate:    wsDest.Cells(1, "A").Select
    Next

    wsDest.UsedRange.EntireColumn.AutoFit
    With wsFrom
        .Activate   'wsFrom.UsedRange.AutoFilter '.ShowAllData
    End With
    Application.ScreenUpdating = True
End Sub

这是您发布的代码，经过一些调整 - 似乎有效：

Public Sub moveKeywordRows1()
    Dim FindMe As String, FindWhat As String, c As Range, lr As Long, wsDest As Worksheet

    Set wsDest = ThisWorkbook.Worksheets("Payroll Detail")
    With ThisWorkbook.Worksheets("NG304")
        Application.ScreenUpdating = False
        For Each c In .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
            FindMe = StrConv(c.Value2, vbProperCase)
            FindWhat = vbNullString
            Select Case UCase(FindMe)
                Case "VCIP":                    FindWhat = "VCIP"
                Case UCase("Company Labor"):    FindWhat = "Company Labor"
            End Select
            If Len(FindWhat) > 0 Then
                c.EntireRow.Cut Destination:=wsDest.Range("A" & lr + 1)
                lr = lr + 1
            End If
        Next
        Application.ScreenUpdating = True
    End With
End Sub

使用Case-Select剪切并粘贴到工作表中

1 个答案: