运行范围内每个字符串结果的脚本

Question

我是 Excel 和 VBA 的新手，所以请多多包涵。

我有一个宏：

从 G1 获取字符串。
在 F 列中搜索匹配项。
如果找到匹配项，复制行并将其粘贴到 sheet 中与 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

运行范围内每个字符串结果的脚本

Running script for every string result in range

excel

vba

xlsx

运行 范围内每个字符串结果的脚本

Running script for every string result in range

excel

vba

xlsx

运行范围内每个字符串结果的脚本