將匹配輸入框結果的行復制到新工作表中

Question

我有一個帶有15,000行的Excel工作表，我試圖用一個單獨的行構建一個加載項。

的要求如下： 1）接受來自輸入框 2串）搜索在列A中所有行的字符串 3）複製匹配行到一個新的工作表，命名爲字符串或如果片材名稱存在，附加到它 4）刪除原始行

我有許多問題。在數組和行的工作表之間，我最終複製了與我的字符串不匹配的行，並且我不能爲了我的生活找出原因。請幫忙！

我有（迄今爲止）的代碼如下：

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