Question

以下宏旨在从用户获取输入字符串，并通过目录（常量）搜索该输入字符串。然后它将相应的信息复制到输入字符串和标题的同一行中。完成复制并粘贴该信息后，宏结束。我想这样做，以便在宏完成复制和粘贴信息后，它要求另一个字符串并再次进行搜索，但在下一行复制信息。如果我能提供更多信息，请告诉我。我已经为此工作了2周，但无法弄清楚。代码如下。

'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

Answer 1

按如下方式应用一些递归：

这个sub将msgbox输入字符串，询问你是否想要再次执行它，获取一个新的输入字符串并自行调用。通过这种方式，它将继续使用不同的字符串（在您的情况下为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

如何在vba

1 个答案: