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

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

出于某种原因，代码在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