循环为行中的每个新数据创建新工作表-MS Excel [英] Looping to Create a New Worksheet for each new data in a Row - MS Excel

问题描述

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

This script is supposed to:
1. Scroll down Column B where the Depts are located.
2. Next, select the entire Row of Data from Col A to Col F
3. Create a New Worksheet with the name of the Dept in Col B
4. Paste that Entire Row that was selected in the newly created worksheet
5. And then, move on to the Next Row until the End of the Data on the Original Data Sheet
6. If the Dept value is different from that of the previous row in Col B, then a New Worksheet is created and the routine begins again on the next Worksheet.

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

For some reason, the code is broken at the 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

推荐答案

尝试一下:

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的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！