如何根据标准将一张 Excel 工作表拆分为多张工作表

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))' 在 Line Destination = wb.Sheets(Diameter)

注意：此代码使用 VBA 运行，但未使用 VB.net 运行

感谢你的帮助

感谢和问候

莫赫拉比

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