Question

我必须在列B中搜索某个字符串，并为文件中出现的所有字符串返回特定范围的单元格。我有代码搜索并查找字符串的所有匹配项，但很难将Path和Owner之间的特定单元格区域复制到新工作表中。问题在于Path和Owner之间的行号是动态的。

Excel结构

SO25755876 question example （包括搜索字符串Kevin的预期结果）。

宏

Sub FindString()
Dim intS As Integer
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet

Application.ScreenUpdating = True

intS = 1
Set wSht = Worksheets("Search Results")
strToFind = Range("I3").Value 'This is where I obtain the string to be searched

With ActiveSheet.Range("B1:B999999")
    Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
    If Not rngC Is Nothing Then
        FirstAddress = rngC.Address
            Do
              (   
                'need help to find copy rows from column B based on values in column A
              )
               intS = intS + 1
               Set rngC = .FindNext(rngC)
            Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
    End If
End With

请帮助我或指导我，因为我是Excel的新手。

Answer 1

此代码将显示找到的路径（变量 sPath ），这是未经测试的：

Sub FindString()
    'Dim intS As Integer
    Dim rngC As Range
    Dim strToFind As String, FirstAddress As String
    Dim wSht As Worksheet, lRowPath As Long, lRowOwner As Long, i As Long, sPath As String

    'Application.ScreenUpdating = True

    'intS = 1
    Set wSht = Worksheets("Search Results")
    strToFind = Range("I3").Value 'This is where I obtain the string to be searched

    'With ActiveSheet.Range("B1:B999999")
    With ActiveSheet.Range("B:B")
        Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
        If Not rngC Is Nothing Then
            FirstAddress = rngC.Address
            Do
                ' Find the "Path:" above the found cell, note that offset too much is not handled: Cells(-1,1)
                i = -1
                Do Until InStr(1, rngC.Offset(i, -1).Value, "Path", vbTextCompare) > 0
                    i = i - 1
                Loop
                lRowPath = rngC.Row + i
                ' Find the Owner row above the found cell
                i = -1
                Do Until InStr(1, rngC.Offset(i, -1).Value, "Owner", vbTextCompare) > 0
                    i = i - 1
                Loop
                lRowOwner = rngC.Row + i
                'need help to find copy rows from column B based on values in column A
                sPath = ""
                For i = lRowPath To lRowOwner - 1
                    sPath = sPath & ActiveSheet.Cells(i, "B").Value ' <-- Update
                Next
                Debug.Print "Searching " & strToFind; " --> " & sPath
                'intS = intS + 1
                Set rngC = .Find(what:=strToFind, After:=rngC, LookAt:=xlPart)
            Loop Until rngC.Address = FirstAddress
        End If
    End With
End Sub

Answer 2

我建议您首先将所有内容加载到内存中，然后进行搜索和操作。

您可以使用用户定义的类型来存储有关路径的信息：

Type PathPermissionsType
    pth As String
    owner As String
    users As Dictionary
End Type

注意：要使用Dictionary，您需要转到工具＆gt; 参考并在Microsoft Scripting Runtime旁边设置复选标记。

您可以使用以下内容加载所有信息：

Function LoadPathPermissions() As PathPermissionsType()
    Dim rngHeaders As Range
    Dim rngData As Range
    Dim iPath As Long
    Dim nPath As Long
    Dim iRow As Long
    Dim nRow As Long
    Dim vHeaders As Variant
    Dim vData As Variant
    Dim pathPermissions() As PathPermissionsType

    Set rngHeaders = Range("A1:A12") 'or wherever
    Set rngData = rngHeaders.Offset(0, 1)
    'Load everything to arrays
    vHeaders = rngHeaders.Value
    vData = rngData.Value
    nRow = UBound(vData, 1)

    nPath = WorksheetFunction.CountIf(rngHeaders, "Path:")
    ReDim pathPermissions(1 To nPath)
    iRow = 1
    'Look for first "Path:" header.
    Do Until InStr(vHeaders(iRow, 1), "Path") <> 0
        iRow = iRow + 1
    Loop
    'Found "Path:" header.
    For iPath = 1 To nPath
        With pathPermissions(iPath)
            'Now look for "Owner:" header, adding to the path until it is found.
            Do Until InStr(vHeaders(iRow, 1), "Owner") <> 0
                .pth = .pth & vData(iRow, 1)
                iRow = iRow + 1
            Loop
            'Found "Owner:" header.
            .owner = vData(iRow, 1)
            '"User:" header is on next row:
            iRow = iRow + 1
            'Now add users to list of users:
            Set .users = New Dictionary
            Do Until InStr(vHeaders(iRow, 1), "Path") <> 0
                .users.Add vData(iRow, 1), vData(iRow, 1)
                iRow = iRow + 1
                If iRow > nRow Then Exit Do ' End of data.
            Loop
        End With
    Next iPath
    LoadPathPermissions = pathPermissions
End Function

使用示例：

Dim pathPermissions() As PathPermissionsType
pathPermissions = LoadPathPermissions()

然后获取包含给定用户路径的数组：

Function GetPathsForUser(ByVal user As String, pathPermissions() As PathPermissionsType) As String()
    Dim iPath As Long
    Dim iPathsWithPermission As Long
    Dim nPathsWithPermission As Long
    Dim pathsWithPermission() As String
    For iPath = LBound(pathPermissions) To UBound(pathPermissions)
        If pathPermissions(iPath).users.Exists(user) Then nPathsWithPermission = nPathsWithPermission + 1
    Next iPath
    ReDim pathsWithPermission(1 To nPathsWithPermission)
    iPathsWithPermission = 0
    For iPath = LBound(pathPermissions) To UBound(pathPermissions)
        If pathPermissions(iPath).users.Exists(user) Then
            iPathsWithPermission = iPathsWithPermission + 1
            pathsWithPermission(iPathsWithPermission) = pathPermissions(iPath).pth
        End If
    Next iPath
    GetPathsForUser = pathsWithPermission
End Function

使用示例：

Dim pathPermissions() As PathPermissionsType
Dim pathsWithPermission() As String
pathPermissions = LoadPathPermissions()
pathsWithPermission = GetPathsForUser("Kevin", pathPermissions)

现在pathsWithPermission是一个数组，其中包含Kevin列为用户的路径。请注意，我还没有处理边缘情况，例如凯文不是任何路径的用户，等等。直到你这样做。

最后，您可以将该数组的内容写入工作表。

根据搜索条件在两个字符串之间复制行

2 个答案: