根据search条件在两个string之间复制行

我必须在B列中search某个string，并为文件中所有出现的string返回特定范围的单元格。 我有代码，search和查找所有出现的string，但难以复制到新的工作表之间的Path和Owner之间的特定范围的单元格。 问题在于Path和Owner之间的行号是dynamic的。

Excel结构

（包括searchstringKevin预期结果）。

macros

 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

这段代码将显示find的path（variablessPath ），这是未经testing的：

 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

我build议你先把所有内容加载到内存中，然后再进行search和操作。

您可以使用用户定义的types来存储有关您的path的信息：

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

注意：要使用Dictionary您需要转到Tools > References并在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() 

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

 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作为用户列出的path的数组。 请注意，我还没有处理边缘情况下，就像凯文是不是任何path的用户，等等。

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