vba - 循环为一行中的每个新数据创建一个新工作表 - MS Excel

Question

该脚本应该:
1. 向下滚动部门所在的 B 列。
2.接下来，选择从Col A到Col F的整行数据
3. 创建一个新的工作表，名称为 B 列中的部门名称
4.粘贴在新创建的工作表中选择的整行
5. 然后，移动到下一行，直到原始数据表上的数据结束
6. 如果 Dept 值与 Col B 中上一行的值不同，则创建一个新工作表，并在下一个工作表上重新开始例程。

由于某种原因，代码在 IF Then 语句处被破坏

Sub Breakout()
Dim FinalRow As Long, I As Long
Dim valuenewsheet As String
Dim Sht As Object

FinalRow = Range("A" & Rows.count).End(xlUp).Row
MsgBox (FinalRow)

ActiveSheet.Range("B1").Select 'selects value in B1
valuenewsheet = (ActiveCell.Value) 'sets value as variable

Sheets.Add.Name = valuenewsheet 'creates new sheet
Worksheets("Sheet1").Select 'reselects original sheet where data is

Set Sht = ThisWorkbook.Sheets("Sheet1") 'sets org data sheet as sht

For I = 1 To FinalRow Step 1 'initiates a loop
    Range(Sht.Cells(I, 6), Sht.Cells(I, 1).End(xlToLeft)).Select 'creates a range of data frm colA to colF one a single row
    Selection.Copy 'copies this data
    Sheets(valuenewsheet).Activate 'activates newly created sheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'pastes data frm slctd range
    ActiveCell.Offset(1, 0).Select 'while on new sheet, select next row
    Sht.Activate 'activate org. data sheet

        If Sht.Cells(I, 2) <> Sht.Cells(I - 1, 2) Then
        Sheets.Add.Name = Sht.Cells(I, 2).Value
        Worksheets(Sht).Select
        Else
        End If
Next I
End Sub

Answer 1

尝试这个:

Sub Breakout()
Dim FinalRow As Long, I As Long
Dim sheetNm As String
Dim shtD As Worksheet, sht1 As Worksheet
Dim wb As Workbook

    Set wb = ActiveWorkbook
    Set sht1 = wb.Worksheets("Sheet1")
    FinalRow = sht1.Cells(Rows.Count, "A").End(xlUp).Row

    For I = 1 To FinalRow  'initiates a loop

        sheetNm = sht1.Cells(I, "B").Value
        'already a sheet for this?
        Set shtD = Nothing
        On Error Resume Next
        Set shtD = wb.Worksheets(sheetNm)
        On Error GoTo 0
        'no sheet already - create one
        If shtD Is Nothing Then
            Set shtD = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
            shtD.Name = sheetNm
        End If
        'copy the values
        shtD.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 6).Value = _
                sht1.Cells(I, "A").Resize(1, 6).Value

    Next I

    sht1.Activate

End Sub