Question

我是Excel和VBA的新手，所以请耐心等待。

我有一个宏：

从G1获取字符串。
搜索F列以进行匹配。
如果找到匹配项，请复制行并将其粘贴到工作表中数据的底部，其名称与G1中的字符串相同。

但后来我需要它：

对G2，G3，G4等字符串执行相同的操作。

我必须遵循以下代码：

Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim LSearchValue As String
Dim shName As String

On Error GoTo Err_Execute

Application.ScreenUpdating = False

LSearchValue = Cells(1, 7)
shName = LSearchValue

LSearchRow = 21

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = Worksheets(shName).Cells(Rows.Count, "A").End(xlUp).Row + 1
If LCopyToRow < 2 Then LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    'If value in column E = LSearchValue, copy entire row to Sheet2
    If Range("E" & CStr(LSearchRow)).Value = LSearchValue Then

        'Select row in Sheet1 to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet2 in next row
        Sheets(shName).Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        LCopyToRow = LCopyToRow + 1

        Sheets("Sheet1").Select

    End If

    LSearchRow = LSearchRow + 1

Wend

Application.CutCopyMode = True
Range("A1").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An Error Occured"

End Sub

有人能帮助我吗？任何帮助将不胜感激

Answer 1

尝试使用以下代码

注意：假设搜索条件列中没有空白单元格，即列“G”。

Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim LSearchValue As String
Dim shName As String

On Error GoTo Err_Execute

Application.ScreenUpdating = False

'let's find the  last cell in G column
Dim lastRow As Long
Dim i as Integer

lastRow = ActiveSheet.Range("G1").End(xlDown).Row

for i = 1 to lastRow

LSearchValue = Cells(i, 7)
shName = LSearchValue

LSearchRow = 21

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = Worksheets(shName).Cells(Rows.Count, "A").End(xlUp).Row + 1
If LCopyToRow < 2 Then LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = LSearchValue, copy entire row to Sheet2
If Range("E" & CStr(LSearchRow)).Value = LSearchValue Then

    'Select row in Sheet1 to copy
    Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
    Selection.Copy

    'Paste row into Sheet2 in next row
    Sheets(shName).Select
    Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
    ActiveSheet.Paste

    LCopyToRow = LCopyToRow + 1

    Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

Application.CutCopyMode = True
Range("A1").Select

Next

MsgBox "All matching data has been copied."

Exit Sub

每个字符串的运行脚本都会产生范围

1 个答案: