如何根據標准將一張 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