Question

我的代码需要帮助。如果要满足以下两个条件，我想根据这两个条件在C列上复制客户的姓名：

G列上的宏查找值=“进行中”
D列上的宏查找值=“ Istry”

换句话说，如果宏在同一行中找到“进行中”和“ istry”，它将自动复制与另一张纸上询问的这两个值相关联的客户名称。

我写了一个代码，但是当我尝试运行它时，我的工作表没有任何结果。

Sub Ss()

Dim finalrow As Long, i As Long, rowpt As Long, colpt As Long

    finalrow = ShSReturn.Range("D" & "G" & Rows.Count).End(xlUp).Row
    rowpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
    colpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row


    Call Entry_Point

    For i = 7 To finalrow
        If ShSReturn.Cells(i, 4).Value = "Istry" & ShSReturn.Cells(i, 7).Value = "Ongoing" Then
            ShSReturn.Cells(i, 3).Copy
            ShPPT.Cells(rowpt + 6, 12).PasteSpecial xlPasteValues

            rowpt = rowpt + 1
            colpt = colpt + 1

        End If

    Next i

End Sub

Answer 1

在这里对您打算使用此代码做一些假设可以快速重写：

Sub Ss()

    Dim finalrow As Long, i As Long, rowpt As Long, colpt As Long

    'Determine how many rows we need to loop:
    finalDRow = ShSReturn.Range("D" & Rows.Count).End(xlUp).Row
    finalGRow = ShSReturn.RAnge("G" & Rows.Count).End(xlUp).Row

    'Loop only through rows were both G and D have records
    If finalDRow < finalGRow Then finalrow = finalDRow Else finalRow = finalGRow


    'I don't know what these two are doing, but they will return the same exact number (the last row populated in column A of whatever worksheet object is in ShPPT
    rowpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
    colpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row


    Call Entry_Point

    'Loop through rows 7 to whatever finalRow shakes out to be above
    For i = 7 To finalrow
        'If column D is "Istry" AND column G is "Ongoing" Then execute this code.
        If ShSReturn.Cells(i, 4).Value = "Istry" AND ShSReturn.Cells(i, 7).Value = "Ongoing" Then
            ShSReturn.Cells(i, 3).Copy
            ShPPT.Cells(rowpt + 6, 12).PasteSpecial xlPasteValues

            rowpt = rowpt + 1
            colpt = colpt + 1

        End If  

    Next i

End Sub

Answer 2

您可以使用过滤器。

请确保设置适当的工作表引用。

按照编写的方式，代码将复制整个行，但是如果您只想复制几个字段，则可以轻松地对其进行修改。

Option Explicit
Option Compare Text
Sub filterName()
    Const strG = "ongoing"
    Const strD = "lstry"
    Dim rCopyTo As Range
    Dim rData As Range
    Dim lastRow As Long, LastCol As Long

With Worksheets("Sheet6")
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rData = .Range(.Cells(1, 1), .Cells(lastRow, LastCol))
End With

Set rCopyTo = Worksheets("sheet7").Cells(1, 1)

Application.ScreenUpdating = False
rData.AutoFilter field:=4, Criteria1:=strD, visibledropdown:=False
rData.AutoFilter field:=7, Criteria1:=strG, visibledropdown:=False

rCopyTo.Cells.Clear
rData.SpecialCells(xlCellTypeVisible).Copy rCopyTo
rData.Worksheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

多个If函数

2 个答案: