Question

我想根据找到的直径数将一个工作表（其中有一个名为Diameter的列）分成许多工作表，在我的情况下是主工作表中的C列，我的代码是

Private Sub Splitter()
    Dim xl As New Excel.Application
    Dim wb As Excel.Workbook
    Dim Source As Excel.Worksheet
    Dim Destination As Excel.Worksheet
    Dim SourceRow As Long
    Dim Lastrow As Long
    Dim DestinationRow As Long
    Dim Diameter As String
    xl.Application.ScreenUpdating = False
    wb = xl.Workbooks.Open("E:\Patches\Main_Master_VB.xlsm")
    Source = wb.Worksheets("Master")
    Lastrow = Source.Cells(Source.Rows.Count, "C").End(Excel.XlDirection.xlUp).Row
    For SourceRow = 2 To Lastrow
        Diameter = Source.Cells(SourceRow, "C").Value
        Destination = Nothing
        On Error Resume Next
        Destination = wb.Sheets(Diameter)
        On Error GoTo 0
        If Destination Is Nothing Then
            Destination = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
            Destination.Name = Diameter
            Source.Rows(1).Copy(Destination.Rows(1))
        End If
        DestinationRow = Destination.Cells(Destination.Rows.Count, "C").End(Excel.XlDirection.xlUp).Row + 1
        Source.Rows(SourceRow).Copy(Destination:=Destination.Rows(DestinationRow))
    Next SourceRow
    xl.Application.ScreenUpdating = True
End Sub

我收到错误索引无效。（来自HRESULT的异常：0x8002000B（DISP_E_BADINDEX））'位于行Destination = wb.Sheets(Diameter)

注意：此代码在VBA上运行，但不在VB.net上运行

感谢您的帮助

谢谢！

Moheb Labib

Answer 1

以下代码修复了由于Option Strict不喜欢后期绑定而导致的编译错误。这可能有助于指出我们的代码出了什么问题。

Imports Microsoft.Office.Interop.Excel
Imports Microsoft.Office.Interop

Private Sub Splitter()
    Dim xl As New Excel.Application
    Dim wb As Excel.Workbook
    Dim Source As Excel.Worksheet
    Dim Destination As Excel.Worksheet
    Dim SourceRow As Long
    Dim Lastrow As Long
    Dim DestinationRow As Long
    Dim Diameter As String
    xl.Application.ScreenUpdating = False
    wb = xl.Workbooks.Open("E:\Patches\Main_Master_VB.xlsm")
    Source = CType(wb.Worksheets("Master"), Worksheet)
    Dim RowCount = Source.Rows.Count
    Dim LastRowRange = CType(Source.Cells(RowCount, "C"), Range)
    Lastrow = LastRowRange.End(Excel.XlDirection.xlUp).Row
    For SourceRow = 2 To Lastrow
        Dim DiameterRange = CType(Source.Cells(SourceRow, "C"), Range)
        Diameter = DiameterRange.Value.ToString
        Destination = Nothing
        'On Error Resume Next
        Destination = CType(wb.Sheets(Diameter), Worksheet)
        'On Error GoTo 0
        If Destination Is Nothing Then
            '                   (Before, After, Count, Type)
            Destination = CType(wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)), Worksheet)
            Destination.Name = Diameter
            Dim row = CType(Source.Rows(1), Range)
            row.Copy(Destination.Rows(1))
        End If
        Dim DestinationRowRange = CType(Destination.Cells(Destination.Rows.Count, "C"), Range)
        DestinationRow = DestinationRowRange.End(Excel.XlDirection.xlUp).Row + 1
        Dim SourceRowRange = CType(Source.Rows(SourceRow), Range)
        SourceRowRange.Copy(Destination:=Destination.Rows(DestinationRow))
    Next SourceRow
    xl.Application.ScreenUpdating = True
End Sub

如何根据其条件将一个Excel工作表拆分为多个工作表

1 个答案: