将匹配input框结果的行复制到新工作表

我有一个有15,000行的Excel表，我试图build立一个加载项来分隔行。

需求如下：1）从input框接受string2）在列A中searchstring的所有行3）将匹配的行复制到新的表单中，命名为stringOR如果存在名称的表单，则附加到该表单上4）删除原始表单行

我有许多问题。 在数组和行的工作表之间，我最终复制行不匹配我的string，我不能为我的生活找出原因。 请帮忙！

我有（到目前为止）的代码如下：

Private Sub FilterToSheets_Click(sender As Object, e As RibbonControlEventArgs) Handles FilterToSheets.Click 'get application Dim application = Globals.ThisAddIn.Application 'get active worksheet Dim workSheet As Excel.Worksheet = application.ActiveSheet 'get header Dim headers = workSheet.Rows(1) 'build range Dim workSheetRow As Integer = 2 Dim lastRow As Integer = workSheet.UsedRange.Rows.Count + 1 Dim rangeString As Object = "(A" + workSheetRow.ToString + ":" + "A" + lastRow.ToString + ")" Dim range = workSheet.Range(rangeString) 'create array of range Dim array = range.Value 'ask for text to filter by Dim inputboxResult As String = InputBox("What string would you like to filter by?", "Filter To Individual Sheets", workSheet.Cells(2, 1).Value) 'only do this if the text is not blank If inputboxResult <> "" Then 'create a new worksheet, name it as the Result, and add headers Dim newWorkSheet 'set starting rows Dim newWorkSheetRow As Integer newWorkSheet = CType(application.Worksheets.Add(), Excel.Worksheet) Try 'we have created a new sheet With newWorkSheet .Name = inputboxResult .Rows(1).Value = headers.Value newWorkSheetRow = 2 End With Catch ex As Exception 'the sheet existed already, use it newWorkSheet = application.Sheets(inputboxResult) End Try 'do the following for each row For row = LBound(array, 1) To UBound(array, 1) application.StatusBar = "Currently processing row number " + row.ToString 'keep going if an error occurs Try 'if the cell's value matches the inputbox result Dim value As String = array(row, 1).ToString If value = inputboxResult Then 'copy data from active sheet to new worksheet newWorkSheet.Rows(newWorkSheetRow).Value = workSheet.Rows(row + 1).Value 'delete row workSheet.Rows(row + 1).Delete() 'we copied data, go to next row on new worksheet newWorkSheetRow += 1 End If Catch ex As Exception MsgBox("Something went wrong!" + vbCrLf + "Error: " + vbCrLf + ex.ToString) Return End Try Next Else Return End If End Sub 

Answer 1

我发现了。 这是行与行之间的错误。 另外，删除行导致一个问题，所以我把它拉出来，并在循环之后。 正确的代码是：

  Private Sub FilterToSheets_Click(sender As Object, e As RibbonControlEventArgs) Handles FilterToSheets.Click 'get application Dim application = Globals.ThisAddIn.Application 'get active worksheet Dim workSheet As Excel.Worksheet = application.ActiveSheet 'get header Dim headers = workSheet.Rows(1) 'build range Dim workSheetRow As Integer = 2 Dim lastRow As Integer = workSheet.UsedRange.Rows.Count Dim rangeString As Object = "(A" + workSheetRow.ToString + ":" + "A" + lastRow.ToString + ")" Dim range = workSheet.Range(rangeString) 'create array of range Dim array = range.Value 'ask for text to filter by Dim inputboxResult As String = InputBox("What string would you like to filter by?", "Filter To Individual Sheets", workSheet.Cells(2, 1).Value) 'only do this if the text is not blank If inputboxResult <> "" Then 'lets be quick about this application.ScreenUpdating = False application.Calculation = Excel.XlCalculation.xlCalculationManual 'create a new worksheet, name it as the Result, and add headers Dim newWorkSheet newWorkSheet = CType(application.Worksheets.Add(), Excel.Worksheet) Dim newWorkSheetRow As Integer = 2 'we have created a new sheet With newWorkSheet .Name = inputboxResult .Rows(1).Value = headers.Value End With 'do the following for each row For row = LBound(array, 1) To UBound(array, 1) Step 1 application.StatusBar = "Currently processing row number " + row.ToString 'keep going if an error occurs Try 'if the cell's value matches the inputbox result Dim value As String = array(row, 1).ToString If InStr(value.ToLower, inputboxResult.ToLower) <> 0 Then 'MsgBox("I should be putting " + value.ToString + " from row " + row.ToString + ".") 'copy data from active sheet to new worksheet newWorkSheet.Rows(newWorkSheetRow).Value = workSheet.Rows(row + 1).Value 'delete row workSheet.Rows(row + 1) = "" 'incriment row newWorkSheetRow += 1 'MsgBox("I did put " + workSheet.Rows.Cells(row, 1).Value.ToString + " from row " + row.ToString + ".") End If Catch ex As Exception MsgBox("Something went wrong!" + vbCrLf + "Error: " + vbCrLf + ex.ToString) Return End Try Next For row = UBound(array, 1) To LBound(array, 1) Step -1 application.StatusBar = "Almost finished. Cleaning up row " + row.ToString workSheet.Rows(row + 1).SpecialCells(Excel.XlCellType.xlCellTypeBlanks).Delete() Next application.StatusBar = "Finished" Else 'catch cancel application.ScreenUpdating = True application.Calculation = Excel.XlCalculation.xlCalculationAutomatic Return End If application.ScreenUpdating = True application.Calculation = Excel.XlCalculation.xlCalculationAutomatic End Sub