在工作表中search所有值的VBA Excel
我有一个工作表，有多个值，我想要做的是search说列“B”的价值，当它发现它复制完整的行，并将其粘贴到别的地方。 我有一个类似的function来做到这一点，但它发现第一个适用于我正在使用它的情况罚款，但停止后，但在这种情况下，我需要它复制所有匹配。 下面是即时使用的代码，只给我一个值
If ExpIDComboBox.ListIndex <> -1 Then strSelect = ExpIDComboBox.value lastRow = wks1.range("A" & Rows.Count).End(xlUp).row Set rangeList = wks1.range("A2:A" & lastRow) On Error Resume Next row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match On Error GoTo 0 If row Then 谢谢
我会build议首先加载数据到数组，然后在这个数组上运行，而不是在单元格上使用Worksheet函数。
'(...) Dim data As Variant Dim i As Long '(...) If ExpIDComboBox.ListIndex <> -1 Then strSelect = ExpIDComboBox.Value lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row 'Load data to array instead of operating on worksheet cells directly - it will improve performance. data = wks1.Range("A2:A" & lastRow) 'Iterate through all the values loaded in this array ... For i = LBound(data, 1) To UBound(data, 1) '... and check if they are equal to string [strSelect]. If data(i, 1) = strSelect Then 'Row i is match, put the code here to copy it to the new destination. End If Next i End If
我已经使用Range.Find()方法来search每一行。 对于find的每一行数据，您input的值与列G中的值相匹配，它将把这些数据复制到Sheet2。 您将需要修改图纸variables名称。
Option Explicit Sub copyAll() Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook Dim strSelect As String, firstFind As String Set wb = ThisWorkbook Set findSheet = wb.Sheets("Sheet1") Set destSheet = wb.Sheets("Sheet2") strSelect = ExpIDComboBox.Value Application.ScreenUpdating = False With findSheet Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues) If Not rngFound Is Nothing Then firstFind = rngFound.Address Do .Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _ .Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address)) Loop While firstFind <> rngFound.Address End If End With Application.ScreenUpdating = True End Sub
我假设你会有列之间的数据A：G？ 否则，您可以修改.Copy和.PasteSpecial方法以适应您的要求。
感谢您的回复。 我厌倦了使用这两种方法，但由于某种原因，他们似乎没有工作。 他们没有给我一个错误，他们只是没有产生任何东西。@ mielk我明白你使用数组来做这个的意思，它会更快，更有效率，但我没有足够的VBA知识来debugging为什么它不起作用。 我尝试了其他的方法，最后得到了它的工作，并认为未来可能会有人试图使这个工作。 再次感谢您的回答:)
Private Sub SearchButton2_Click() Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected selectedString = DomainComboBox.value lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search i = 2 'used to only create a new sheet is something is found On Error Resume Next row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match On Error GoTo 0 If row Then For Each ws In Sheets Application.DisplayAlerts = False If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results Next Application.DisplayAlerts = True Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets ws.Name = "Search Results" 'renames the worksheet to search results wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected If domainRange.value = selectedString Then wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents End If i = i + 1 'moves onto the next row ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting Next domainRange ' goes to next value Else MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found Exit Sub End If End If End Sub
谢谢。
注意这不是做这个阅读mielk的答案和其他答案的最有效的方法，因为如果你能使它们工作，它们会更好。