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

Question

我想根据找到的直径数量，将一个名为"直径"的列的工作表拆分为多个表，在我的情况下，它是主表中的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:PatchesMain_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:PatchesMain_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