1

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.

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

1 Answer 1

6

Try this:

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
3
  • Tim, I tried your code and it worked perfectly. While I'm happy that it works, I have to say that I'm really disappointed in myself. Your code is simple yet elegant. It creates the new sheets while at the same time copying the data. I suck at this man. I'm thankful for your solution and grateful for the time you took on this. I wish I could repay the favor, Tim, but apparently I'm no good at coding, so maybe I could mow your lawn or walk the dogs?
    – John Shaw
    Commented Mar 2, 2015 at 7:40
  • @JohnShaw - all our code sucked at some point. Nothing to worry about - the trick is to keep improving over time... Commented Mar 2, 2015 at 15:59
  • @JohnShaw - and I meant to add your code does not suck! Commented Mar 2, 2015 at 20:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.