Question

我有一个包含15,000行的Excel工作表，我正在尝试构建一个用于分隔行的加载项。

要求如下： 1）从inputbox接受字符串 2）在列A中搜索字符串的所有行 3）将匹配的行复制到一个新的工作表，以字符串OR命名，如果存在名称的工作表，则附加到它 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

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

    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

将与inputBox结果匹配的行复制到新工作表

1 个答案: