如何在vba中重复此宏

以下宏用于从用户获取输入字符串，并在目录常量中搜索该输入字符串。然后，它将相应的信息复制到输入字符串的同一行以及标题中。复制和粘贴完该信息后，宏结束。我想这样做，在宏完成复制和粘贴信息后，它会要求另一个字符串并再次进行搜索，但会在下一行复制信息。 请让我知道，如果我可以提供任何更多的信息，我已经在这方面工作了两个星期，现在无法找出它。代码如下

'Author: Michael Majdalani
Public WS As Worksheet
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)

Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
Dim p As Integer
ReDim Folders(0)



'This is where the folder path is chosen, for the current application
'It is constant, If you would like to choose a different folderpath
'Uncomment the commented lines and comment the declaration of myfolder

If IsMissing(Folderpath) Then
    Set WS = Sheet1
    'With Application.FileDialog(msoFileDialogFolderPicker)
        '.Show
        myfolder = "O:QUALITY\INSPECTION REPORTS\"
    'End With

'This is where the user is prompted to enter the string, if no string is entered
'A message will appear. If a string is entered, It will enter the headers
'"Search String" and "links" and the correlated information
'Value here keeps track of the directory and which subfolders/folders
'it is searching through

    Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
    If Str = "" Then MsgBox "No string entered, Please try again"
    WS.Range("A1") = "Search string:"
    WS.Range("A2") = Str
    WS.Range("B1") = "Links"
    Folderpath = myfolder
    Value = Dir(myfolder, &H1F)
Else
    If Right(Folderpath, 2) = "\\" Then
        Exit Sub
    End If
    Value = Dir(Folderpath, &H1F)
End If

'The first part of this do Until loop has a lot to do with how the maneuvering is completed
'within the folder path and directory for excel to search through every folder/subfolder
'needed.

Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(Folderpath & Value) = 16 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        ElseIf (Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm") And Left(Value, 1) <> "~" Then
            On Error Resume Next
            Dim wb As Workbook
            Set wb = Workbooks.Open(Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz")
            On Error GoTo 0
            'If there is an error on Workbooks.Open, then wb Is Nothing:
            If wb Is Nothing Then
                Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
                WS.Range("A" & Lrow).Value = Value
                WS.Range("B" & Lrow).Value = "Password protected"
            Else
                'For each sheet in the workbooks, the next loop will search through the first
                'column of every sheet in every workbook found in the directory chosen.
                'It then creates the link, as well as updating value to end the loop.

                For Each sht In wb.Worksheets
                    'Expand all groups in sheet and Unprotect
                    sht.Unprotect

                    sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8

                    'c here is used to search for the user input string
                    Set c = sht.Columns(1).Find(Str, After:=sht.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        Do
                            Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row
                            WS.Range("B" & Lrow).Value = Value
                            WS.Hyperlinks.Add Anchor:=WS.Range("B" & Lrow), Address:=Folderpath & Value, SubAddress:= _
                            "'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
                            Set c = sht.Cells.FindNext(After:=c)
                            Cells.EntireColumn.AutoFit

                        Loop While Not c Is Nothing And c.Address <> firstAddress
                    End If

                    'if c is nothing, continue
                    If c Is Nothing Then GoTo Cont Else


                    'if c is equal to our searched string then it will loop through the
                    'adjacent thirty cells copying and pasting all the information
                    'to the main workbook
                    If Str = c.Formula Then
                       Dim i As Integer

                       For i = 1 To 30

                    If IsEmpty(wb.Sheets(sht.Name).Range(firstAddress).Offset(0, i)) Then GoTo Done

                        Dim cnt As Long


                        'cnt is the amount of cells between the searched string and the top
                        'of that workbook, used to copy the headers to the main workbook
                        cnt = ((Range(firstAddress, "A1").Cells.Count) - 1) * -1


                        'Copy and paste info
                        wb.Sheets(sht.Name).Range(firstAddress).Offset(0, i).Select
                        Selection.Copy

                        WS.Range("B2").Offset(0, i).PasteSpecial

                        'Copy and paste header info
                        wb.Sheets(sht.Name).Range(firstAddress).Offset(cnt, i).Select
                        Selection.Copy

                        WS.Range("B1").Offset(0, i).PasteSpecial

                        Next i





                    'When done, close the workbook and autofit the cells on the main
                    'workbook
Done:                   wb.Close False
                        Cells.EntireColumn.AutoFit
                        End
                    End If
              'Continues the loop if the string is not found
Cont:             Next sht
                wb.Close False
                End If
            End If
        End If
    'Increments value to the next directory
    Value = Dir
Loop

'Recursive loop
For Each Folder In Folders
    Call SearchWKBooksSubFolders(Folderpath & Folder & "\", Str)
Next Folder

Cells.EntireColumn.AutoFit
End Sub

---

应用一些递归，如下所示：

此子模块将msgbox输入字符串，询问是否要再次执行，获取新的输入字符串并调用自身。这样，它将继续使用case folderpath中的不同字符串，直到用户退出

编辑：添加了一个递增器，它允许递归每次取下一行

Public SomeIncrementer as Integer

Sub DoStuff(str As String)
Dim repeat As Integer
Dim nextstring As String
    Worksheets(1).Range("A" & SomeIncremeter).value = str
    repeat = MsgBox("Again?", vbYesNo)
    If repeat = vbYes Then
        SomeIncrementer = SomeIncrementer + 1
        nextstring = InputBox("Next string?")
        DoStuff (nextstring)
    End If
End Sub

'And start from here:
Sub Test()
    SomeIncrementer = 1
    DoStuff "Hello"
End Sub

---

只需以一个提示结束，如果是，请询问此sub的下一个输入并调用sub本身。如果没有，让它转到end sub。好的，这在重复过程中起了作用。但是有两个问题，第一个是它覆盖了以前搜索的数据。我希望它增加一行，然后在第一行之后通过信息。第二个原因是excel工作表没有响应我的单击，它运行时没有宏，没有冻结。这是两个新问题：覆盖旧值：您可以使用子对象范围之外的增量，不要在子对象内使用dim，但是在这里的子testparams行之前使用public。Excel工作表对我的点击没有响应——这是有意义的，只要东西还在运行，它就不会响应。如果你想要更明确的信息，你必须澄清你的问题并描述确切的期望行为。所以我会在子函数外部声明整数，将其设置为0，然后在子函数内部递增？我不能在子函数外部将其设置为0，如果我在子函数内部执行，那么每次我递归调用它，它将重置为0。我仍然遇到以前的数据被覆盖的问题。我试图保留一个常数p，这样我就可以将这个WS.RangeA2=Str偏移为WS.RangeA2.Offsetp，0=Str，但我不知道如何通过函数callSee edit使p递增/保存-我添加了一个递增器，以便每次函数调用自己时都取下一行。你可以对p做同样的事情，只是不要把它声明为常数。另一种方法是对p进行乘法，以获得每次迭代的起始单元格，但只有当您确切知道要复制多少行时，这种方法才有效。最后，您还可以将该起始行设置为.endxlDown.row+1或类似的值。