Question

这个脚本应该是：
1.向下滚动显示Depts所在的B列 2.接下来，从Col A到Col F选择整个数据行 3.使用Col B中的Dept名称创建一个新工作表 4.粘贴在新创建的工作表中选择的整行 5.然后，转到下一行，直到原始数据表上的数据结束为止 6.如果Dept值与Col B中上一行的值不同，则会创建一个新工作表，并在下一个工作表上再次开始例程。

出于某种原因，代码在IF Then Statement

处被破坏

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

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

1 个答案: