Question

我是VBA的初学者。我正在尝试构建一个宏，它可以根据差异化标准将整行复制并粘贴（值）到新工作表。在这种情况下，区分标准将是特定细胞的内容。换句话说，如果单元格包含单词“Caviar”，则将行复制到工作表1中，否则复制到工作表2.当我手动运行（逐行）时，以下宏工作。

Sub Search_and_copy()
Dim rng As String
rng = Sheets("40").Range("F11").Value
Dim rowNo As Integer
rowNo = 6
Dim celltxt As String
celltxt = Sheets("40").Range("P11").Value

        rowNo = 6
        If Sheets("40").Range("F11").Value = "254" Then
                If InStr(celltxt, "CAVIAR") Then
                    Rows("11:11").Select
                    Selection.Copy
                    Sheets("Sheet1").Select
                    If IsEmpty(Cells(rowNo, 1)) Then
                            Sheets("Sheet1").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Else:   Do Until IsEmpty(Cells(rowNo, 1))
                                rowNo = rowNo + 1
                            Loop
                            Sheets("Sheet1").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                    Sheets("40").Select
                    Application.CutCopyMode = False
                    Selection.Delete Shift:=xlUp
                Else
                    Rows("11:11").Select
                    Selection.Copy
                    Sheets("Sheet2").Select
                    If IsEmpty(Cells(rowNo, 1)) Then
                            Sheets("Sheet2").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Else:   Do Until IsEmpty(Cells(rowNo, 1))
                                rowNo = rowNo + 1
                            Loop
                            Sheets("Sheet2").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                    Sheets("40").Select
                    Application.CutCopyMode = False
                    Selection.Delete Shift:=xlUp

                End If
        End If

End Sub

但是，只要我引入一个循环（参见下面的代码），就不再适当地区分并且所有行都被复制到同一个工作表中。我做错了什么？

Sub Search_and_copy()
Dim rng As String
rng = Sheets("40").Range("F11").Value
Dim rowNo As Integer
rowNo = 6
Dim celltxt As String
celltxt = Sheets("40").Range("P11").Value


    Do Until IsEmpty(Sheets("40").Range("F11").Value)

        rowNo = 6
        If Sheets("40").Range("F11").Value = "254" Then
                If InStr(celltxt, "CAVIAR") Then
                    Rows("11:11").Select
                    Selection.Copy
                    Sheets("Sheet1").Select
                    If IsEmpty(Cells(rowNo, 1)) Then
                            Sheets("Sheet1").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Else:   Do Until IsEmpty(Cells(rowNo, 1))
                                rowNo = rowNo + 1
                            Loop
                            Sheets("Sheet1").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                    Sheets("40").Select
                    Application.CutCopyMode = False
                    Selection.Delete Shift:=xlUp
                Else
                    Rows("11:11").Select
                    Selection.Copy
                    Sheets("Sheet2").Select
                    If IsEmpty(Cells(rowNo, 1)) Then
                            Sheets("Sheet2").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Else:   Do Until IsEmpty(Cells(rowNo, 1))
                                rowNo = rowNo + 1
                            Loop
                            Sheets("Sheet2").Cells(rowNo, 1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                    Sheets("40").Select
                    Application.CutCopyMode = False
                    Selection.Delete Shift:=xlUp

                End If

        End If

    Loop

End Sub

Answer 1

（第一个）问题是你永远不会改变循环中celltxt的值。在将Sheets("40").Range("P11").Value读入字符串后，您永远不会更改它。这意味着InStr(celltxt, "CAVIAR")将始终相同，直到Sub结束。您需要做的就是在循环中更新它。

当你正在做的另一件事是应用一点DRY并将你的公共代码提取到一个函数中。您的If和Else之间的唯一区别是工作表名称。尝试这样的事情：

Sub Search_and_copy()
    Dim celltxt As String

    Do Until IsEmpty(Sheets("40").Range("F11").Value)
        celltxt = Sheets("40").Range("P11").Value
        If Sheets("40").Range("F11").Value = "254" Then
            If InStr(celltxt, "CAVIAR") Then
                DontRepeatYourself "Sheet1"
            Else
                DontRepeatYourself "Sheet2"
            End If
        End If
    Loop

End Sub

Private Sub DontRepeatYourself(sheet As String)
    Dim rowNo As Long
    rowNo = 6
    Rows("11:11").Select
    Selection.Copy
    Sheets(sheet).Select
    Do Until IsEmpty(Cells(rowNo, 1))
        rowNo = rowNo + 1
    Loop

    Sheets(sheet).Cells(rowNo, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                           SkipBlanks:=False, Transpose:=False
    Sheets("40").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub

“如果instr”没有使用循环

1 个答案: