none
Macro Code for Splitting one sheet data into multiples sheets RRS feed

  • Question

  • Hi,

    I have one concern that I have to split one sheet data into multiples sheets.

    Based on condition as below.

    Main Sheet:

    Columns : Student Name , Std No, Std Branch, Year, .....

    Main Sheet consists of Student details of all the branches of engineering .

    I need to split the Main Sheet into separate sheet for each of the Individual student based on student name.

    Would appreciate if any body can provide such macro code.

    Thanks in advance

    Regards,

    Avis

    Thursday, May 2, 2013 8:15 AM

Answers

  • Try this:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    Thursday, May 2, 2013 8:28 AM

All replies

  • Try this:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    Thursday, May 2, 2013 8:28 AM
  • Hello Hans Vogelaar,

    More thanks for the code.

    Is it possible to split the data into separate files instead of sheets ?

    Thanks,

    Avis

    Thursday, May 2, 2013 6:03 PM
  • The following version will first create sheets, then save those as separate files and delete the sheets.

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.SaveAs Filename:=TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    Thursday, May 2, 2013 6:29 PM
  • In addition to what Hans gave you, you should check this out, for some additional ideas of doing what you want to do:

    http://www.rondebruin.nl/win/s3/win006.htm


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Friday, May 10, 2013 8:10 PM
  • Hello Hans Vogelaar,

    Do you have one that does the above (create sheets, then save those as separate files and delete the sheets) but will also copy over header, footer, formulas, special formatting etc.?

    Thanks,

    Joel Wilson

    Monday, September 23, 2013 5:37 PM
  • Try this version:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets(Worksheets.Count))
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.SaveAs Filename:=TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, September 23, 2013 8:37 PM
  • Hello Hans Vogelaar and thanks for your help!

    I am getting a Run-time error '13': Type mismatch and the macro highlights the below line

      Set TrgSheet = Worksheets(Worksheets(Worksheets.Count))

    Please advise.

    Joel J. Wilson

    Tuesday, September 24, 2013 3:14 PM
  • I am trying to split data from the primary sheet into multiple workbooks based on the below conditions.

    Columns: Cardholder name, post dt, trans dt, vendor name, trans amt, cost center, newcost ctr, acct, new act and business purpose.

    I need to split the Main Sheet into separate workbooks for each of the Individuals based on “Cardholder  name”.

    I would also like the macro to copy over header, footer, subtotals, locked cells (if locked in the primary sheet lock in the new work book), special formatting and etc.

    Joel J. Wilson

    Tuesday, September 24, 2013 3:41 PM
  • Oops, sorry, that was a careless edit of the original code. Change that line to

      Set TrgSheet = Worksheets(Worksheets.Count)


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, September 24, 2013 6:44 PM
  • This pulled over everything I needed except the subtotals, is it possible for the macro to also include that?

    Additionally, I noticed when I tried to lock certain cells for the spread sheet to split out into individual workbooks the macro had an error.. Is it possible to do all the above and how the cells that are locked in the origionbal workbook be distributed to individual workbooks and still be locked with the same password?

    Thanks for all your help!

    Best Regards,

    Joel J. Wilson
    Monday, October 7, 2013 3:14 PM
  • I fear it's becoming too complicated.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, October 8, 2013 10:49 PM
  • Try this.

    http://www.rondebruin.nl/win/s3/win006_1.htm

    Comment out this line.

    '.PasteSpecial xlPasteValues



    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Tuesday, October 8, 2013 10:58 PM
  • This worked GREAT however is there macro that will automatically update so that any time I put an additional row of information into the master sheet, the additional worksheets update as well?
    Friday, November 1, 2013 6:32 PM
  • Hello,

    I am using the following script but I would like to see if there's a way to keep a certain sheet on each of the files it breaks out. I have info in Sheet2 that is used for Vlookups and data validation on the main file but when it splits, Sheet2 is just pulled into a seperate workbook. I'm sure it's an easy code using Const but I just don't know VBA that well. I appreciate any assistance you can provide!

    Angie

    Sub SplitData4()
    Const NameCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
    Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
    Dim sh As Worksheet, Master As String
    On Error Resume Next
    Set r = Application.InputBox("Click in the column to extract by", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    iCol = r.Column
    t = Now
    Application.ScreenUpdating = False
    With ActiveSheet
        Master = .Name
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        iStart = 2
        For i = 2 To LastRow
            If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                iEnd = i
                Sheets.Add after:=Sheets(Sheets.Count)
                Set ws = ActiveSheet
                On Error Resume Next
                ws.Name = .Cells(iStart, iCol).Value
                On Error GoTo 0
                ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
                .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
                iStart = iEnd + 1
            End If
        Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
    If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
        Prefix = InputBox("Enter a prefix (or leave blank)")
        Application.ScreenUpdating = False
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> Master Then
                sh.Copy
                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                ActiveWorkbook.Close
            End If
         Next sh
         Application.ScreenUpdating = True
    End If
    End Sub

    Wednesday, February 5, 2014 10:57 PM
  • Does this do what you want?

        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> Master And sh.Name <> "Sheet2" Then
                Worksheets(Array(sh.Name, "Sheet2")).Copy
                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & _
                    Prefix & sh.Name & ".xlsx"
                ActiveWorkbook.Close
            End If
         Next sh
    


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, February 5, 2014 11:30 PM
  • Hello Hans,

    Thank you so much! This worked perfectly!

    Could you advise on how to keep the formatting of the header row? And possibly to hide the Sheeet2 upon split?

    You have already made my life easier! I greatly appreciate it.

    Angie

    Saturday, February 22, 2014 4:13 PM
  • To preserve the formatting of the header row, change the line

                ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value

    to

                .Range(.Cells(1, 1), .Cells(1, LastCol)).Copy ws.Range("A1")

    The line to hide Sheet2 is

        Worksheets("Sheet2").Visible = xlSheetHidden

    If you insert this line above the loop that saves the separate workbooks, Sheet2 will be hidden in all those separate workbooks too.

    If you insert the above line below the loop, Sheet2 will only be hidden in the source workbook.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Saturday, February 22, 2014 9:25 PM
  • This worked perfectly. You inspired me to do more on my own and I was able to find all sorts of other codes that made the macro do exactly what I wanted. I wanted to share here since this site has helped me so much! This splits file, maintains formatting, sets specific cloumn widths and auto fits the rest, keeps the panes frozen, included filters in first row, unprotects a locked file and re-protects it at the end before splitting.

    The one question I have is how can I add additional tabs like the Sheet 2, where it will keep in each workbook and hide?

    So grateful for your help. This will eliminate hours of work for me and my co-worker!

    Angie

    Sub SplitData4()
    Const NameCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
    Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
    Dim sh As Worksheet, Master As String
    On Error Resume Next
    ActiveSheet.Unprotect ("Your Password")
    Set r = Application.InputBox("Click in the column to extract by", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    iCol = r.Column
    t = Now
    Application.ScreenUpdating = False
    With ActiveSheet
        Master = .Name
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        iStart = 2
        For i = 2 To LastRow
            If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                iEnd = i
                Columns.AutoFit
                Columns("A:D").ColumnWidth = 14.14
                Columns("Y").ColumnWidth = 75
                Sheets.Add after:=Sheets(Sheets.Count)
                Set ws = ActiveSheet
                On Error Resume Next
                ws.Name = .Cells(iStart, iCol).Value
                On Error GoTo 0
                .Range(.Cells(1, 1), .Cells(1, LastCol)).Copy ws.Range("A1")
                .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
                iStart = iEnd + 1
                End If
        Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
    If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
        Prefix = InputBox("Enter a prefix (or leave blank)")
        Application.ScreenUpdating = False
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> Master And sh.Name <> "Sheet2" Then
               Worksheets(Array(sh.Name, "Sheet2")).Copy
                Worksheets("Sheet2").Visible = xlSheetHidden
                Range("A1").Select
                With ActiveWindow
                .SplitColumn = 6
                .SplitRow = 1
                End With
                ActiveWindow.FreezePanes = True
                Range("A1:Y1").AutoFilter
                ActiveSheet.Protect Password:="Your Password"
                ActiveWorkbook.Protect Password:="Your Password", Structure:=True, Windows:=False
                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                ActiveWorkbook.Close
            End If
         Next sh
         Application.ScreenUpdating = True
    End If
    End Sub


    • Edited by AngieS1607 Monday, February 24, 2014 5:37 PM
    Monday, February 24, 2014 5:35 PM
  • You could use

        For Each sh In ThisWorkbook.Worksheets
            Select Case sh.Name
                Case Master, "Sheet2", "Sheet3", "OtherSheet"
                    ' Skip
                Case Else
                    Worksheets(Array(sh.Name, "Sheet2", "Sheet3", "OtherSheet")).Copy
                    Dim sh2 As Worksheet
                    For Each sh2 In Worksheets
                        If sh2.Name <> sh.Name Then
                            sh2.Visible = xlSheetHidden
                        End If
                    Next sh2
                    Range("A1").Select
                    With ActiveWindow
                        .SplitColumn = 6
                        .SplitRow = 1
                    End With
                    ActiveWindow.FreezePanes = True
                    Range("A1:Y1").AutoFilter
                    ActiveSheet.Protect Password:="Your Password"
                    ActiveWorkbook.Protect Password:="Your Password", Structure:=True, Windows:=False
                    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                    ActiveWorkbook.Close
            End Select
        Next sh


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, February 24, 2014 8:22 PM
  • Hello Hans,

    I have 2 questions I hope you can help me with. The original code in my previous post is not keeping the column width on the last destination workbook that it splits out. Any idea of how I can fix that? I hadn't noticed this when I was testing.

    My second question is how can I modify this code to keep more than one row at the top on each workbook? I am trying to modify this macro for 2 different projects, one file only has the header in row 1 and the other needs to keep everything in row 1-7. I tried modifying to this code but I am getting a syntax error.

    Set r = Application.InputBox("Click in the column to extract by", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    iCol = r.Column
    t = Now
    Application.ScreenUpdating = False
    With ActiveSheet
        Master = .Name
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
            .Range(.Cells(7, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(8, iCol), Order1:=xlAscending,
            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        iStart = 2
        For i = 8 To LastRow
            If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                iEnd = i
                Columns.AutoFit
                Columns("E").Hidden = True
                Columns("F").Hidden = True
                Columns("G").Hidden = True
                Columns("I").Hidden = True
                Columns("N:V").Hidden = True
                Columns("AF").Hidden = True
                Columns("AE").ColumnWidth = 75
                Sheets.Add after:=Sheets(Sheets.Count)
                Set ws = ActiveSheet
                On Error Resume Next
                ws.Name = .Cells(iStart, iCol).Value
                On Error GoTo 0
                .Range(.Cells(1, 1), .Cells(1, LastCol)).Copy ws.Range("A7")
                .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A8")
                iStart = iEnd + 1
                End If
        Next i
    End With

    I'm sorry, I have 3 questions. How can I sort by column A,B,C, D and then F in each destination file?              As always, your help is greatly appreciated!

    Angie 


    • Edited by AngieS1607 Wednesday, March 5, 2014 2:51 AM
    Wednesday, March 5, 2014 2:34 AM
  • 1) You first set the column widths, then copy data to the new sheet. Perhaps you should set the column widths in the new sheet ws AFTER copying the data.

    2) The part that sorts the column on which you want to extract should be

        .Range(.Cells(7, 1), .Cells(LastRow, LastCol)).Sort _
            Key1:=.Cells(8, iCol), Order1:=xlAscending, _
            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom

    3) I'm not sure which range you want to sort.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, March 5, 2014 10:20 AM
  • Hello Hans,

    Thank you for the reply.

    I tried the code you have above but I'm still getting the same error.

    Run-time error ‘1004’:

    The sort reference is not valid. Make sure that it’s within the data you want to sort, and the first sort by box isn’t the same or blank.

    I do apologize for being such a novice. I know this is beyond my current skill set but I cannot thank you enough for the assistance.

    Angie

    Wednesday, March 5, 2014 4:29 PM
  • I'd have to see the workbook.

    Could you create a stripped-down copy of the workbook (without sensitive information) and make it available through one of the websites that let you upload and share a file, such as Microsoft OneDrive (https://onedrive.live.com), FileDropper (http://filedropper.com) or DropBox (http://www.dropbox.com). Then post a link to the uploaded and shared file here.

    Or register at www.eileenslounge.com (it's free) and post a message in the Excel forum. You can attach files up to 250 KB to a post there (zipped if necessary).


    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Wednesday, March 5, 2014 9:54 PM
  • Thank you Mr.Hans Vogelaar ,it is a fantastic macro which solved my several problem.May GOD increase your knowledge.Thanks again.
    Tuesday, April 29, 2014 5:16 PM
  • Hi Hans,

    Just a quick question on splitting worksheet. I am using  the code you provided and its working great! Thank you and Angie for sharing with us.

    My question is, some of the sheet doesn't come out with column name instead its comes out something like 'Sheet58'. Is there a way that I can tweak the code little bit so that this problem can be fixed. Thank you for your help

    Monday, June 2, 2014 2:38 PM
  • Some characters aren't allowed in sheet names, for example !, [, ], / and ?

    Do you have characters like that in the column used to name the sheets?


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Saturday, June 14, 2014 12:14 PM
  • Hi there,

    Thankyou very much for your help, your codes have been awesome.

    One small problem I have currently, is that after running the code, while the sheets are split nicely, they are carried forward to the next sheet as well. E.g

    I have 

    alex $10 (info)

    alex $30 (info)

    bob $15 (info)

    bob $12 (info)

    charlie $16 (info

    The code will split this master data into 3 files, Alex.xls, Bob.xls,Charlie.xls . However, Bob.xls will contain a sheet called Alex (with alex's data) and Charlie.xls will have Alex & Bob's sheets as well. Could you assist me on this issue? Greatly appreciate the help

    Tuesday, September 2, 2014 2:05 PM
  • This is a long thread, and there have been many iterations of the code. Which version are you using?

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, September 2, 2014 3:39 PM
  • Try this version:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets(Worksheets.Count))
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.SaveAs Filename:=TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Hi, thanks for the reply. I'm currently using this one, with the edit to the slight copy&paste mistake of the 

    Set TrgSheet = Worksheets(Worksheets(Worksheets.Count))

    to

    Set TrgSheet = Worksheets(Worksheets.Count)

    Tuesday, September 2, 2014 4:03 PM
  • Yikes! The Worksheet.SaveAs method saves the entire workbook instead of the specified sheet.

    Here is a corrected version:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets.Count)
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:=TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, September 2, 2014 5:08 PM
  • Hi,

    Sorry I know the above is a few months old but when I enter the above coding nothing seems to save anywhere.

    Also could you show me how/where I would add the code for keeping column widths from master sheet?

    Thanks

    Adam

    Thursday, May 14, 2015 8:24 PM
  • Did you try the samples here?

    http://www.rondebruin.nl/win/s3/win006.htm


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, May 14, 2015 8:39 PM
  • Thanks, I managed to get the last one above working but it keeps all of the original table just with empty cells for information not copied how can I make it so only the section of table I need is copied over and keeping the formatting (column widths)
    • Edited by AdzNW Friday, May 15, 2015 4:18 PM
    Friday, May 15, 2015 9:03 AM
  • Hi,

    I tried this, it does split the values into separate tabs, but not separate files with the different names.

    I want to split the data based on column A, then have them all into separate sheets with the file name same as the name in column A.

    Also, if possible to leave about 5 rows from the top of the sheet, as I want to have a heading there.

    There is more than one way to do this in the thread, just not sure which one works best.

    thank you.

    Wednesday, February 17, 2016 10:21 PM
  • Hello there.  Did you read through the link I posted?  I don't think you did.

    http://www.rondebruin.nl/win/s3/win006_3.htm


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    • Proposed as answer by AndrewM001 Thursday, February 18, 2016 3:24 PM
    Wednesday, February 17, 2016 10:53 PM
  • Thank you very much. Sorry, I did not scroll all the way down, I was responding to one of them earlier articles.

    Your website is very very helpful, you've done great work.

    Wednesday, February 17, 2016 11:20 PM
  • Click 'propose as answer' if it helped you.

    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, February 18, 2016 12:03 AM
  • Thanks for the knowledge.  Your code saved me so much time!
    Tuesday, August 23, 2016 2:31 PM
  • Hi Hans, 

    I have a macro coding which I found online which works well. But I need rows 1 to row 11 to be copied across to all the distributed worksheets. How and where do I add this to my current macro coding? Your help would be much appreciated! 

    Sub Copy_To_Workbooks()

        Dim My_Range As Range
        Dim FieldNum As Long
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim ws2 As Worksheet
        Dim MyPath As String
        Dim foldername As String
        Dim Lrow As Long
        Dim cell As Range
        Dim CCount As Long
        Dim WSNew As Worksheet
        Dim ErrNum As Long

        Set My_Range = Range("A12:M" & LastRow(ActiveSheet))
        My_Range.Parent.Select

        If ActiveWorkbook.ProtectStructure = True Or _
           My_Range.Parent.ProtectContents = True Then
            MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                   vbOKOnly, "Copy to new workbook"
            Exit Sub
        End If

     
        FieldNum = 1


        My_Range.Parent.AutoFilterMode = False


        If Val(Application.Version) < 12 Then

            FileExtStr = ".xls": FileFormatNum = -4143
        Else
      
            If ActiveWorkbook.FileFormat = 56 Then
                FileExtStr = ".xls": FileFormatNum = 56
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        End If


        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        ActiveSheet.DisplayPageBreaks = False


        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("BSLSummary").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0


        Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
        ws2.Name = "BSLSummary"


        MyPath = Application.DefaultFilePath


        If Right(MyPath, 1) <> "\" Then
            MyPath = MyPath & "\"
        End If


        foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
        MkDir foldername

        With ws2

            My_Range.Columns(FieldNum).AdvancedFilter _
                    Action:=xlFilterCopy, _
                    CopyToRange:=.Range("A3"), Unique:=True


            Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
            For Each cell In .Range("A4:A" & Lrow)


                My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

      
                CCount = 0
                On Error Resume Next
                CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                         .Areas(1).Cells.Count
                On Error GoTo 0
                If CCount = 0 Then
                    MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                         & vbNewLine & "It is not possible to copy the visible data." _
                         & vbNewLine & "Tip: Sort your data before you use this macro.", _
                           vbOKOnly, "Split in worksheets"
                Else
                
                    Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

       
                    My_Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNew.Range("A1")
           
                        .PasteSpecial Paste:=8
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With


                    On Error Resume Next
                    WSNew.Parent.SaveAs foldername & _
                                        cell.Value & FileExtStr, FileFormatNum
                    If Err.Number > 0 Then
                        Err.Clear
                        ErrNum = ErrNum + 1

                        WSNew.Parent.SaveAs foldername & _
                                            "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum

                        .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
                                                        "Error_" & Format(ErrNum, "0000") & FileExtStr & """)"

                        .Cells(cell.Row, "A").Interior.Color = vbRed
                    Else
                        .Cells(cell.Row, "B").Formula = _
                        "=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
                    End If

                    WSNew.Parent.Close False
                    On Error GoTo 0
                End If

      
                My_Range.AutoFilter Field:=FieldNum

            Next cell
            .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
            .Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
            .Cells(3, "A").Value = "Unique Values"
            .Cells(3, "B").Value = "Full Path and File name"
            .Cells(3, "A").Font.Bold = True
            .Cells(3, "B").Font.Bold = True
            .Columns("A:B").AutoFit

        End With


        My_Range.Parent.Select
        ActiveWindow.View = ViewMode
        ws2.Select
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With

    End Sub



    Thursday, September 1, 2016 1:50 AM
  • I have posted a reply in your own thread Macro Code for Splitting one sheet data into multiples.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, September 1, 2016 5:50 AM
  • Thank you so much Hans! You saved me days of work! Can I ask where you started learning VBA coding? Do you know of any books that I could start reading? I am new to it all but can see the advantages of knowing this skill set. 
    Thursday, September 1, 2016 11:16 PM
  • I am mostly self-taught.

    John Walkenbach has written many useful books about Excel and VBA - see http://spreadsheetpage.com/index.php/books


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, September 2, 2016 8:30 AM
  • Hi,

    I have used the above macro for splitting sheets into multiple sheets, i got an error # 400 VBA 

    Can you please suggest me to heal the error.

    Thanks in Advance

    Anvesh

    Thursday, December 8, 2016 9:35 AM
  • Could you create a stripped-down copy of the workbook (without sensitive information) and make it available through one of the websites that let you upload and share a file, such as FileDropper (http://filedropper.com) or DropBox (https://www.dropbox.com). Then post a link to the uploaded and shared file here.

    Or register at www.eileenslounge.com (it's free) and start a thread in the Excel forum. You can attach files up to 250 KB to a post there (zipped if necessary).


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, December 8, 2016 3:32 PM
  • Hi Hans Vogelaar

    I use your macro code. it is helpful for me. i need more help to after split row in sheet. There two row in each sheet. i want to convert row to column i use following code.

    Sub Movefromrowtocolumn()
    Range("A1:F1").Select
    Selection.Copy
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    End Sub

    but i want convert row (A2:F2) and paste in column B5 in sametime. Now i runing to different macro in each sheet and run filter manual in each sheet.

    it is possible to run macro split row in different sheets and convert raw to column and start filter delete 0 and blank row data thro macro code .

    br,

    guru123168

    Monday, March 20, 2017 12:29 PM
  • You could run the following macro after splitting the data:

    Sub TransposeRows()
        Dim wsh As Worksheet
        For Each wsh In Worksheets
            Select Case wsh.Name
                ' Edit/expand the list as needed
                Case "Summary", "Data"
                    ' Skip these sheets
                Case Else
                    wsh.Range("A1").CurrentRegion.Copy
                    wsh.Range("A5").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            End Select
        Next wsh
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, March 20, 2017 4:27 PM
  • Hi

    I wanted make something like below, but as i have no skils in vba - How to lock TransponseRow ranges, with each new sheet it copy/paste n + 1 cell? How i prevent that?

    I would be very thankful.

    -----------------------------------------------------------

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets.Count)
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1

        'TransposeRows - How to lock transponse ranges?

            Set TrgSheet = Worksheets(i)
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:="C:\Testfile\" + TrgSheet.Name & ".txt", fileFormat:=xlText
            ActiveWorkbook.Close
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub

    ---------------------------------------------------------------------

    Sub TransposeRows()
        Dim wsh As Worksheet
        For Each wsh In Worksheets
            Select Case wsh.Name
                ' Edit/expand the list as needed
                Case "list", "test"
                    ' Skip these sheets
                Case Else
        Range("A2").Select
        Selection.Copy
        Range("B1").Select
        ActiveSheet.Paste
        Columns("A:A").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlToLeft
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            End Select
        Next wsh
    End Sub 

                        
    Thursday, April 6, 2017 1:47 PM
  • I'm sorry, I don't understand your question.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, April 6, 2017 4:21 PM
  • Hi

    I'll try explain more as i don't understand whats wrong.
    I made some modifications as i don't need header and want data in one column in separate fail.
    Now SplitData make files ok, but TransposeRows moving with each different data one step away from data frame .

    1.file
    Range("A2").Select
    Selection.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Columns("A:A").Select

    2.file
    Range("B2").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Columns("A:B").Select

    and so on ...
    from third file is all empty :(

    Friday, April 7, 2017 7:10 AM
  • Perhaps this?

    Sub SplitData()
        Const NameCol = "A"
        Const FirstRow = 1
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgCol As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets.Count)
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                SrcSheet.Rows(SrcRow).Copy
                TrgSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            Else
                TrgCol = TrgSheet.Cells(1, TrgSheet.Columns.Count).End(xlToLeft).Column + 1
                SrcSheet.Rows(SrcRow).Copy
                TrgSheet.Cells(1, TrgCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
            End If
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:="C:\Testfile\" + TrgSheet.Name & ".txt", FileFormat:=xlText
            ActiveWorkbook.Close
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, April 7, 2017 9:30 AM
  • Unfortunately not, and I'm very sorry that I didn't say right away that I have data in two columns. Like ...

    name1 - data1
    name1 - data2
    name1 - data3
    name2 - data1
    name2 - data2
    name2 - data3
    name2 - data4

    etc. And i'd like get file name1.TXT ...

    name1
    data1
    data2
    data3

    and so on  ...


    Friday, April 7, 2017 3:33 PM
  • Do your data start in row 2 (with headers in row 1), or do they start in row 1?

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, April 7, 2017 7:49 PM
  • Hi
    My data start in row 2 (with headers in row 1)
    Monday, April 10, 2017 8:56 AM
  • This hopefully does what you want...

    Sub SplitData()
        Const NameCol = "A"
        Const DataCol = "B"
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets.Count)
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = Student
                TrgSheet.Cells(1, 1).Value = Student
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, 1).End(xlUp).Row + 1
            TrgSheet.Cells(TrgRow, 1).Value = SrcSheet.Cells(SrcRow, DataCol).Value
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:="C:\Testfile\" + TrgSheet.Name & ".txt", FileFormat:=xlText

            ActiveWorkbook.Close
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, April 10, 2017 4:04 PM
  • Yes, many thanks!
    Now i have lot of study - what part do what :)
    Tuesday, April 11, 2017 8:21 AM
  • Hi,

    I have one concern that I have to split one sheet data into multiples sheets.

    Based on condition as below.

    Main Sheet:

    Columns Name:List Of Information, Akshay,Alan,Jon,Akshay, Amey,Tina,Akshay,Jon as column name .

    Row Name: Highest Qualification, College Name, DOB,.....

    Main Sheet consists of Data of above persons name in columns.

    I need to split the Main Sheet into separate sheet for each of the Individual Person based on same column name together in one sheet

    Would appreciate if any body can provide such macro code.

    Thanks in advance

    Regards,

    Akshay

    Monday, July 31, 2017 9:10 AM
  • Hi Hans,

    I have been following you closely and learning alot from your forums, But lately i am stuck at a project. No the above code for splitting data works just fine for me and i have make little tweeks to it the part i am stuck at is i have a sheet with raw data (mastersheet), I am able to split workload to individual sheet with the agents name however i have few workload named "to be reassigned" I need this to be automatically distributed to each agent could this be done?

    Wednesday, September 27, 2017 6:37 PM
  • How do you want those workloads to be assigned to agents? Is there some kind of 'rule'?

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, September 27, 2017 8:36 PM
  • Hi Hans,

    Thank you for your reply sorry i had a bad time trying to reset my password here, Please find how the overall work allocation happens.

    have 20+ agents working I have a master sheet with all the data new work and the old work, I am currently able to separate the old work with the agent name into different multiple sheets and i use the macro from one of your post to help me doing that but I have to manually calculate and assign new work depending on the OLD.

    For eg John has 20 previous days work pending his target is 80 i assign 60 and for Tim 60 Prev days i assign 20. If youcan help me or show me a way to assign new work depending on their old work would be great.

    The final result i am looking for is there are diff sheets with names of agents along with previous days work I want the new work to go to their respective sheet according to their work pending can this be done?

    I have also attached the current macro I run for Splitting the Previous days work and the New work comes to a separate sheet as New work.

        Const NameCol = "AK"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Agent
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub

    The above is the macro i use to split the OLD work but the NEW work i have to manually assign to their respectieve sheet and run another macro to email the sheets across. Is there a way all this can happen using one macro.

    Thank you so much again been learning a lot from you.

    If incase you want a copy of the sheet i use i can email it to you.

    Thanks in advance

    Regards,

    Niroshan 

    Friday, September 29, 2017 10:59 PM
  • Seeing (a copy of) the workbook might help, but you'll still have to explain in great detail what "assign new work" means. I'll have to know exactly where to enter the data, and where I can find the target for each agent etc.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Saturday, September 30, 2017 11:43 AM
  • Hi Hans,

    I have shared the link of the file i have uploaded there is a TAB named Steps giving you a little insight of all that is going on in that file. Here is the link https://files.fm/u/wzzdddde

    Please do let me know if you need any further clarification.

    I really do appreciate your time thank you so much in advance

    Regards,

    Niroshan  

    Monday, October 2, 2017 5:40 PM
  • I have taken a quick look, but I don't grasp what you're doing yet. it's late, however. I'll take another look tomorrow.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, October 2, 2017 9:20 PM
  • I'm afraid I don't understand how you want to assign work. I hope that someone else will be able to help you. Sorry.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, October 3, 2017 4:08 PM
  • No issues Hans, I know its quite confusing thank you for looking into this for me 
    Tuesday, October 3, 2017 6:14 PM
  • Hello Hans,

    The above code is working fine for me. But I'm getting the data in horizontal. 

    But I've tried to get verticle data in separate sheets. 

    Could you please help me on this.

    I'm getting every header row in each sheet like that I need every row data in verticle with a header row.

    A    B   C

    1     2    3

    4     5    6

    -------------Sheet 1----------

    A   1 

    B    2

    C    3

    -------------Sheet 2 ----------

    A   4 

    B   5

    C   6

    Etc...

    Please let me know.

    Thanks in advance.

    Friday, October 20, 2017 8:45 AM
  • See if this does what you want:

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
        Next r
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, October 20, 2017 10:46 AM
  • Hello Hans,

    Thanks for your quick response and help. that is really helpful.

    But I'm getting the sheets name like Sheet1,2 etc instead of Column A name.

    Please help me on this. 

    Also,

    I need to save each sheet data in pdf format. I've tried this in using below code

    Sub <g class="gr_ gr_32 gr-alert gr_spell gr_inline_cards gr_run_anim ContextualSpelling ins-del multiReplace" data-gr-id="32" id="32">Splitbook</g>()
                MyPath = ThisWorkbook.Path
                For Each sht In ThisWorkbook.Sheets
                sht.Copy
                ActiveSheet.Cells.Copy
                ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
                ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
                ActiveWorkbook.SaveAs _
                Filename:=MyPath & "\" & sht.Name & ".pdf"
                ActiveWorkbook.Close savechanges:=False
                Next sht
                End Sub

    It is working But I'm getting an error while opening the PDF file.

    "Not supported file type or because the file has been damaged. (For <g class="gr_ gr_20 gr-alert gr_gramm gr_inline_cards gr_run_anim Punctuation only-del replaceWithoutSep" data-gr-id="20" id="20">example:</g> it was sent an email attachment and was not correctly decoded) 

    Thanks,

    Satya.


    • Edited by Satya55 Friday, October 20, 2017 11:24 AM
    Friday, October 20, 2017 11:20 AM
  • Hello Team,

    Sorry to bother, It is a bit urgent.

    Below code is working perfectly. But I need output data like shown in below

    • I need column A name should be Sheets name [Now I'm getting the sheet1 and2 etc..]
    • Next, save those all sheets to PDF using that sheet name.

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
        Next r
        Application.ScreenUpdating = True
    End Sub

    Thanks,

    Satya

    Friday, October 20, 2017 1:31 PM
  • I am just a volunteer, doing this in my free time.

    Try this:

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Dim strName As String
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            strName = CStr(wshS.Range("A" & r).Value)
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
            wshT.Name = strName
            wshT.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & strName & ".pdf"
        Next r
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, October 20, 2017 1:47 PM
  • Hello Hans,

    Sorry for the trouble.

    Thank you very much for your help.

    The provided code has been working 100% perfectly.

    But a small correction in the code. Please have a look when you have downtime.

    After running this code, I'm getting data in excel sheets and in Pdf

    https://social.msdn.microsoft.com/Forums/getfile/1147926

    https://social.msdn.microsoft.com/Forums/getfile/1147927

    So, I've saved one pdf manually, Can we get pdf [Extended B column] like shown in below.

    https://social.msdn.microsoft.com/Forums/getfile/1147928

    I've tried to get data like shown in above by doing wrap text and some text alignments. Please have look when you have downtime.

    Thank you in advance.

    Satya.

    Friday, October 20, 2017 3:03 PM
  • Most of your links don't work, but you could try this:

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Dim strName As String
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            strName = CStr(wshS.Range("A" & r).Value)
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
            wshT.Range("A1:B1").EntireColumn.AutoFit ' *** New ***
            wshT.Name = strName
            wshT.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & strName & ".pdf"
        Next r
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, October 20, 2017 7:18 PM
  • Hello Hans,

    Just saying thank you will never repay your help on this.

    Satya.


    Saturday, October 21, 2017 4:25 AM
  • Hello Hans,

    Hope you are doing good.

    The above code is working perfectly. But some of the B column record cells have the around 400 characters. When I try to convert that sheet into PDF, above mentioned data is creating no.of new pdf pages. Even if it is a single character. I've tried with adding column width, wrap and fit the page. But no luck.

    When you have downtime Plese, look at the underscored code.

    Is it possible to align the scale of that A & B column data sheet to "Fit All Columns on one page"?

    OR Wrap the column data in the output pdf file. 

    Can we get those two columns data in 1 or 2 PDF pages by using Fit all column on one page TRUE? Against the column cells data. 

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Dim strName As String
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            strName = CStr(wshS.Range("F" & r).Value)
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
            With ActiveSheet.PageSetup
                .FitToPagesTall = True
                .FitToPagesWide = True
                .PaperSize = xlPaperLetter
            End With
            wshT.Name = strName
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & strName & ".pdf"
        Next r
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub

    Thanks in Advance,

    Satya.

    Wednesday, December 6, 2017 10:28 AM
  • Try this version:

    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Dim strName As String
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            strName = CStr(wshS.Range("F" & r).Value)
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
            With wshT.Range("B:B")
                .ColumnWidth = 75
                .WrapText = True
            End With
            wshT.PageSetup.PaperSize = xlPaperLetter
            wshT.Name = strName
            wshT.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=ThisWorkbook.Path & "\" & strName & ".pdf"
        Next r
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, December 6, 2017 10:53 AM
  • Hello Hans,

    Thanks for your help. I've added few more lines of code my requirement.

     I've 700+ records data until CL column. When I try to run below code I'm getting Runtime error 1004. And it is extracting only 300+ records.So I've tried by splitting the data into 3 parts [250records]. Then only it is working. 

    Your file could not be printed due to an error on \ Path\. There are several possible reasons:

    There may not be enough memory available. Try closing files and programs you aren't using. 

    If you use a network for printing  

    Is there any chance to get all data in one file? There may be a problem


    Sub TransposeData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim r As Long
        Dim m As Long
        Dim n As Long
        Dim strName As String
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious).Row
        n = wshS.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        For r = 2 To m
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            strName = CStr(wshS.Range("F" & r).Value)
            wshS.Range("A1").Resize(1, n).Copy
            wshT.Range("A1").PasteSpecial Transpose:=True
            wshS.Range("A" & r).Resize(1, n).Copy
            wshT.Range("B1").PasteSpecial Transpose:=True
            With wshT.Range("A:A")
                .ColumnWidth = 50
                .WrapText = True
            End With
            With wshT.Range("B:B")
                .ColumnWidth = 100
                .WrapText = True
            End With
            With ActiveSheet.PageSetup
            .Zoom = False
            .FitToPagesWide = 1
            End With
            wshT.PageSetup.PaperSize = xlPaperLetter
            wshT.Name = strName
            wshT.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=ThisWorkbook.Path & "\" & strName & ".pdf"
        Next r
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub

    Thanks,

    Satya.

    Thursday, December 7, 2017 8:45 AM
  • It's impossible for me to know what causes the problem without seeing (a copy of) the workbook.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, December 7, 2017 11:40 AM
  • The following version will first create sheets, then save those as separate files and delete the sheets.

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = Worksheets.Count To n + 1 Step -1
            Set TrgSheet = Worksheets(i)
            TrgSheet.SaveAs Filename:=TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    Hans -

    Based on the OP's question, I believe this code should do what I want it to do. Unfortunately, I don't have any programming skills and I don't know what I need to do to adapt it to my spreadsheet. Like the OP, I am looking to break my data into multiple tabs and then into multiple files.

    My data is 10 columns and 9,734 rows. I want to break this apart into offices (titled RB), which is in column B. The titles of each column are titled "OW", "RB", "MO", "OO", "Name", "ET", "PT", "BST", "FS", and "Notes". The name of the tab with the data is "DATA".

    I attempted to run the first macro that splits the data into tabs without making new files and it only gives me a blank worksheet. I couldn't figure out how to adapt it without creating errors.

    Thank you,

    Hayley



    • Edited by evilityb Sunday, December 31, 2017 1:39 AM
    Sunday, December 31, 2017 1:38 AM
  • @evilityb:

    Since the office names are in column B, the second column, you need to change

        Const NameCol = "A"

    to

        Const NameCol = "B"

    Assuming that the column headers (titles) are in row 1 and that the data begin in row 2, no other changes should be needed.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Sunday, December 31, 2017 10:19 AM
  • @evilityb:

    Since the office names are in column B, the second column, you need to change

        Const NameCol = "A"

    to

        Const NameCol = "B"

    Assuming that the column headers (titles) are in row 1 and that the data begin in row 2, no other changes should be needed.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thank you so much! I really appreciate your help. This helped me determine that the source of my error was actually the names of the offices (several over 30 characters, 1 with a character not allowed in tab titles), not the code itself. It worked like a charm and now my team has a shot of hitting our ridiculously tight deadline. If I could take you out for a beer, I would. 
    Sunday, December 31, 2017 3:59 PM
  • Hello Hans,

    Hope you can help me. I am trying to adjust some of the coding above to split and export an excel but my VBA skills are limited.

    This is what I have to do:

    - I have an excel with 2 sheets, one with a database with formulas and second one ("mapping" sheet) has references for the first one including drop list sources;

    - I need to split the database after a column, keeping the formulas and formatting and save them in separate excels with the second excel hidden in each one so that the formulas can work;

    - Also, from my database sheet I must keep the first 6 lines since they all contain different drop lists that change the information in the sheet. And if possible, the first 2 lines must be hidden.

    I have been trying to use this code, given by Angie above, but I simply don't have the knowledge to adjust it. I have added it below in original form not with the modifications I have tried.

    Thank you in advance

    Sub SplitData4()
    Const NameCol = "A"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
    Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
    Dim sh As Worksheet, Master As String
    On Error Resume Next
    Set r = Application.InputBox("Click in the column to extract by", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    iCol
    = r.Column
    t
    = Now
    Application.ScreenUpdating = False
    With ActiveSheet
       
    Master = .Name
       
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
       
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
       
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
           
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        iStart
    = 2
       
    For i = 2 To LastRow
           
    If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                iEnd
    = i
               
    Sheets.Add after:=Sheets(Sheets.Count)
               
    Set ws = ActiveSheet
               
    On Error Resume Next
                ws
    .Name = .Cells(iStart, iCol).Value
               
    On Error GoTo 0
                ws
    .Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
               
    .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
                iStart
    = iEnd + 1
           
    End If
       
    Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
    If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
       
    Prefix = InputBox("Enter a prefix (or leave blank)")
       
    Application.ScreenUpdating = False
       
    For Each sh In ThisWorkbook.Worksheets
           
    If sh.Name <> Master Then
                sh
    .Copy
               
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                ActiveWorkbook.Close
            End If
         Next sh
         Application.ScreenUpdating = True
    End If
    End Sub

    Friday, April 20, 2018 1:37 PM
  • Please provide sufficient details.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, April 20, 2018 2:44 PM
  • I am working on a database with commitments for different clients, with their outstanding in each month, name, system id and status, manager, class of client, location and different lines that do evaluations between selected dates. I need to split the database after the manager column.

    My first 6 rows contain the head of the database and different filters that select the date of comparison, type of outstanding, and other drop lists.

    I hope this helps

    Friday, April 20, 2018 2:56 PM
  • See if this does what you want...

    Sub SplitData4()
        Const DatabaseSheet = "Database"
        Const OtherSheet = "Other"
        Const FirstRow = 7
        Dim LastRow As Long, LastCol As Long, i As Long, iStart As Long, iEnd As Long
        Dim ws As Worksheet, r As Range, iCol As Long, Prefix As String
        Dim sh As Worksheet, Master As String
        On Error Resume Next
        Set r = Application.InputBox("Click in the column to extract by", Type:=8)
        On Error GoTo 0
        If r Is Nothing Then Exit Sub
        iCol = r.Column
        Application.ScreenUpdating = False
        With ActiveSheet
            LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LastCol = .Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            .Range(.Cells(FirstRow, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(FirstRow, iCol), Header:=xlGuess
            iStart = FirstRow
            For i = FirstRow To LastRow
                If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                    iEnd = i
                    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    On Error Resume Next
                    ws.Name = .Cells(iStart, iCol).Value
                    On Error GoTo 0
                    ws.Range(ws.Cells(1, 1), ws.Cells(FirstRow - 1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(FirstRow - 1, LastCol)).Value
                    .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A" & FirstRow)
                    ws.Range("A1:A2").EntireRow.Hidden = True
                    iStart = iEnd + 1
                End If
            Next i
        End With
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
            Prefix = InputBox("Enter a prefix (or leave blank)")
            Application.ScreenUpdating = False
            For Each sh In ThisWorkbook.Worksheets
                If sh.Name <> DatabaseSheet And sh.Name <> OtherSheet Then
                    Worksheets(Array(sh.Name, OtherSheet)).Copy
                    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                    ActiveWorkbook.Close
                End If
             Next sh
             Application.ScreenUpdating = True
        End If
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, April 20, 2018 3:23 PM
  • It copies all the information and the formulas, it doesn't copy any of the drop lists nor the formatting.

    But its a step forward, I will work on it to see if those can also be copied. I know at least that for formatting you mentioned something above.

    Thank you

    Friday, April 20, 2018 3:39 PM
  • You could change

                    ws.Range(ws.Cells(1, 1), ws.Cells(FirstRow - 1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(FirstRow - 1, LastCol)).Value

    to

                     .Range(.Cells(1, 1), .Cells(FirstRow - 1, LastCol)).Copy Destination:=ws.Cells(1, 1)


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, April 20, 2018 4:20 PM
  • Thank you, it works. And now it copies the drop lists also. I have added lines to autofit the new sheets and to hide the 2nd copied sheet. Here is the final code, if anyone else needs it.

    After this, it is time to make it so it can split 3 different databases and copy all. Hope this is possible.

    Sub SplitData4()
         Const DatabaseSheet = "Database"
         Const OtherSheet = "Other"
         Const FirstRow = 7
         Dim LastRow As Long, LastCol As Long, i As Long, iStart As Long, iEnd As Long
         Dim ws As Worksheet, r As Range, iCol As Long, Prefix As String
         Dim sh As Worksheet, Master As String
         On Error Resume Next
         Set r = Application.InputBox("Click in the column to extract by", Type:=8)
         On Error GoTo 0
         If r Is Nothing Then Exit Sub
         iCol = r.Column
         Application.ScreenUpdating = False
         With ActiveSheet
             LastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
             LastCol = .Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
             .Range(.Cells(FirstRow, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(FirstRow, iCol), Header:=xlGuess
             iStart = FirstRow
             For i = FirstRow To LastRow
                 If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
                     iEnd = i
                     Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                     On Error Resume Next
                     ws.Name = .Cells(iStart, iCol).Value
                     On Error GoTo 0
                     .Range(.Cells(1, 1), .Cells(FirstRow - 1, LastCol)).Copy Destination:=ws.Cells(1, 1)
                     .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A" & FirstRow)
                     ws.Range("A1:A2").EntireRow.Hidden = True
                     ActiveSheet.UsedRange.EntireColumn.AutoFit
                     iStart = iEnd + 1
                 End If
             Next i
         End With
         Application.CutCopyMode = False
         Application.ScreenUpdating = True
         If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
             Prefix = InputBox("Enter a prefix (or leave blank)")
             Application.ScreenUpdating = False
             For Each sh In ThisWorkbook.Worksheets
                 If sh.Name <> DatabaseSheet And sh.Name <> OtherSheet Then
                     Worksheets(Array(sh.Name, OtherSheet)).Copy
                     Worksheets("Other").Visible = xlSheetHidden
                     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Prefix & sh.Name & ".xlsx"
                     ActiveWorkbook.Close
                 End If
              Next sh
              Application.ScreenUpdating = True
         End If
     End Sub

    Monday, April 23, 2018 9:01 AM
  • I’m using the code below but my document has 7 header lines that I would like to copy on to the new tabs. Please could come one help? pre class="prettyprint lang-vb" style="">Sub SplitData() Const NameCol = "A" Const HeaderRow = 1 Const FirstRow = 2 Dim SrcSheet As Worksheet Dim TrgSheet As Worksheet Dim SrcRow As Long Dim LastRow As Long Dim TrgRow As Long Dim Student As String Application.ScreenUpdating = False Set SrcSheet = ActiveSheet LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row For SrcRow = FirstRow To LastRow Student = SrcSheet.Cells(SrcRow, NameCol).Value Set TrgSheet = Nothing On Error Resume Next Set TrgSheet = Worksheets(Student) On Error GoTo 0 If TrgSheet Is Nothing Then Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count)) TrgSheet.Name = Student SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow) End If TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1 SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow) Next SrcRow Application.ScreenUpdating = True End Sub
    
    

    Regards, Hans Vogelaar


    Wednesday, June 27, 2018 1:31 AM
  • Is there any way to get it to copy more than one header row?
    Wednesday, June 27, 2018 1:32 AM
  • @Steven2909: Here is a modified version.

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 8
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Application.ScreenUpdating = False
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Resize(FirstRow - HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, June 27, 2018 7:14 AM
  • Hey Hans,

    Thanks a ton for this code. However my data has multiple rows with the same value in column 'A'. Any suggestion on what should I do.

    Monday, July 2, 2018 4:33 AM
  • @infiniteahead: the code already takes care of that.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, July 2, 2018 7:07 AM
  • Hi Hans Vogelaar,

    I would like to ask, is it possible to split data from main sheet into multiple sheets which already existed but have the same format?

    I'll give you the overview, I have many data in main sheet 1 which consist of data from month to date, then I run macro to split into multiple worksheet based on column that I want to split. Secondly, I have another main sheet (main sheet 2) which consist of data from year to date, then I want to do the exact way as before with macro to split data. But I want to combine data from year to date main sheet into worksheets that already consist of data from month to date. But I don't know how to write macro with the second condition like that. Could you help me on this?

    Thanks in advance.

    Thursday, July 5, 2018 4:39 AM
  • Hey Hans,

    My Bad. It works wonderfully. However, I need a further help. After splitting the data into sheets basis Column'A' Values, I need the data in the sheets to be further divided into two tables basis binary values in another Column (say Column 'M'). 

    Can you please help?

    Tuesday, July 10, 2018 6:29 AM
  • Can you explain in more detail what you mean by "I need the data in the sheets to be further divided into two tables basis binary values in another Column (say Column 'M')."

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, July 10, 2018 7:08 AM
  • Hi,

    Basically this is what I need.

    I have some 10 columns, I have to slipt the data into sheets based on value in Column 'A'. The column 'g' has simple true false values. So, in every sheet, I need the macro to create two tables, one for rows corresponding to true and another corresponding to false. 

    An added problem is that the number of true and false values keeps on changing.

    Could you help please?

    Saturday, July 14, 2018 11:31 AM
  • Here is an attempt:

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const SplitCol = "G"
        Const FirstRow = 2
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Dim Dict As Object
        Application.ScreenUpdating = False
        Set Dict = CreateObject("Scripting.Dictionary")
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            If SrcSheet.Cells(SrcRow, SplitCol).Value = True Then
                Student = SrcSheet.Cells(SrcRow, NameCol).Value
                Set TrgSheet = Nothing
                On Error Resume Next
                Set TrgSheet = Worksheets(Student)
                On Error GoTo 0
                If TrgSheet Is Nothing Then
                    Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    TrgSheet.Name = Student
                    SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
                    Dict.Add Key:=Student, Item:=True
                End If
                TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
                SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
            End If
        Next SrcRow
        For SrcRow = FirstRow To LastRow
            If SrcSheet.Cells(SrcRow, SplitCol).Value = False Then
                Student = SrcSheet.Cells(SrcRow, NameCol).Value
                Set TrgSheet = Nothing
                On Error Resume Next
                Set TrgSheet = Worksheets(Student)
                On Error GoTo 0
                If TrgSheet Is Nothing Then
                    Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    TrgSheet.Name = Student
                    SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
                End If
                TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
                If Dict.Exists(Student) Then
                    If Dict(Student) = True Then
                        TrgRow = TrgRow + 1
                        SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(TrgRow)
                        TrgRow = TrgRow + 1
                        Dict(Student) = False
                    End If
                End If
                SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
            End If
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Saturday, July 14, 2018 10:25 PM
  • Hans,

    This is awesome man. Exactly what I needed.:)

    I need some more help though. Now that I have the data in seperate sheets, I need to create separate email drafts with this data along with some text which changes slightly depending on whether there is one or two tables in the sheets.

    Could you possible help with that. basically I need a code which creates draft containing some text and the data from each sheet. So, if there are 10 sheets, there should be 10 draft.

    Thanks in advance.

    Thursday, August 2, 2018 12:24 PM
  • Could you please start a new thread/topic for this new question? Thanks in advance!

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, August 2, 2018 2:39 PM
  • Hi Hans,

    In case you have a solution for this, here is the link to the new thread : https://social.msdn.microsoft.com/Forums/Lync/en-US/9b84e947-014f-45b5-8550-82b2f1f5b3a9/how-to-copy-excel-data-from-separate-sheets-into-multiple-outlook-drafts?forum=exceldev

    Sunday, August 5, 2018 10:18 AM
  • Hi Hans

    I am not really good at creating Macros, so wondering if you can help

    I have two macros set up.

    First one spits out the individual tabs based on unique value in Column J and

    Second, Macro adds the totals in column K to each tabs.

    I want to merge both macros in one, so after spitting the tabs it adds the totals in column "K" on each tab.

    Other requirements are:

    Planes to freeze on each tab at Column "C", row at "11".

    Column width to fit to content.

    Sort by Column "C" and then by "D" in each tab.

    Here are the two macros. I will really appreciate your help.

    Many Thanks

    MACRO -1

    Sub parse_data()
    Dim LR As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 10
    Set ws = Sheets("Customer_statement")
    LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A10:L10"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To LR
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub

    MACRO 2 to add Totals in Column K

    Sub EnterFormula()

        Dim ws As Worksheet
        Dim LR As Long
       
        Application.Calculation = xlManual
        Application.ScreenUpdating = False


        For Each ws In Application.Worksheets
           
            ws.Activate
           
            'Find last row in i
            LR = Range("K" & Rows.Count).End(xlUp).Row
           
            'Select last cell + 1 & enter formula
           
            Range("K" & LR + 1).Formula = "=SUM(K2:K" & LR & ")"
           
            Calculate
       
       
        Next ws
            
        Application.ScreenUpdating = True
        Application.Calculation = xlAutomatic

    End Sub

    Friday, October 12, 2018 3:52 AM
  • Try this macro:

    Sub parse_data()
        Dim LR As Long
        Dim ws As Worksheet
        Dim LR2 As Long
        Dim vcol, i As Integer
        Dim icol As Long
        Dim myarr As Variant
        Dim title As String
        Dim titlerow As Integer
        Application.ScreenUpdating = False
        vcol = 10
        Set ws = Sheets("Customer_statement")
        LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
        title = "A10:L10"
        titlerow = ws.Range(title).Cells(1).Row
        icol = ws.Columns.Count
        ws.Cells(1, icol) = "Unique"
        For i = 2 To LR
            On Error Resume Next
            If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
                ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
            End If
        Next
        myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
        ws.Columns(icol).Clear
        For i = 2 To UBound(myarr)
            ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
            If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
                Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
            Else
                Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
            End If
            ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            With Sheets(myarr(i) & "")
                LR2 = .Cells(.Rows.Count, vcol).End(xlUp).Row + 1
                .Cells(LR2, vcol).Formula = "=SUM(K2:K" & LR2 & ")"
                .UsedRange.Sort Key1:=Range("C1"), Key2:=Range("D1")
                .Columns.AutoFit
                Application.Goto .Range("C11")
                ActiveWindow.FreezePanes = True
            End With
        Next
        ws.AutoFilterMode = False
        ws.Activate
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, October 12, 2018 8:46 AM
  • Hi Hans,

    Would it be possible to split data from a Master sheet (which is titled “Master”) to different sub sheets? I have 14 columns, I need to split the rows onto new sheets based on the value of column C which is Transfer Type. It can only be:

    ·         Adviser to Partner

    ·         Partner to Adviser

    ·         Adviser & MA to Adviser

    ·         Asia

    ·         Practice Shuffle

    In those 5 new sheets it needs to have the same column headers. Is it also possible so that it updates automatically when putting new transfers on the Master sheet? And can the column headers also filter?

     

    I’m new to writing macro and have been struggling with making this.

     

    Can you please help?

    Friday, October 12, 2018 9:54 AM
  • The code to split the data is basically the same as that near the beginning of this thread, with an additional line to add filter arrows:

    Sub SplitData()
        Const TypeCol = "C"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim TransferType As String
        Application.ScreenUpdating = False
        Set SrcSheet = Worksheets("Master")
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, TypeCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            TransferType = SrcSheet.Cells(SrcRow, TypeCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(TransferType)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                SrcSheet.Copy After:=Worksheets(Worksheets.Count)
                Set TrgSheet = Worksheets(Worksheets(Worksheets.Count))
                TrgSheet.Cells.ClearContents
                TrgSheet.Name = TransferType
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
                TrgSheet.UsedRange.AutoFilter
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, TypeCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.ScreenUpdating = True
    End Sub

    Automatically copying new transfers would be complicated.


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, October 12, 2018 11:43 AM
  • Hi Hans,

    Thank you for your response, that all works!

    So would it not be possible to put data into the 'Master' sheet and then it automatically filter out onto the correct sub sheet? 

    Thanks

    Monday, October 15, 2018 11:53 AM
  • I repeat: that would be complicated.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, October 15, 2018 8:02 PM
  • @ sam151018

    This is a pretty good start, I think.  Notice: To have all this fully automated would be quite difficult.  I think whenever you make any kind of change to your sheet it would be firing off the code, which would almost certainly interrupt your work, and it would always be running, always be running, always be running, etc.

    In the code you see four filter examples that you can use, we use example 1 in this macro and I commented the other 3 examples in the code.
    1: Criteria in the code (=Netherlands, see the tips below the macro)
    2: Filter on ActiveCell value
    3: Filter on Range value (D1 in this example)
    4: Filter on InputBox value

    Sub Copy_With_AutoFilter1()
    'Note: This macro use the function LastRow
        Dim My_Range As Range
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim FilterCriteria As String
        Dim CCount As Long
        Dim WSNew As Worksheet
        Dim sheetName As String
        Dim rng As Range
    
        'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
        'and the header of the first column, D is the last column in the filter range.
        'You can also add the sheet name to the code like this :
        'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
        'No need that the sheet is active then when you run the macro when you use this.
        Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
        My_Range.Parent.Select
    
        If ActiveWorkbook.ProtectStructure = True Or _
           My_Range.Parent.ProtectContents = True Then
            MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                   vbOKOnly, "Copy to new worksheet"
            Exit Sub
        End If
    
        'Change ScreenUpdating, Calculation, EnableEvents, ....
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        ActiveSheet.DisplayPageBreaks = False
    
        'Firstly, remove the AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        'Filter and set the filter field and the filter criteria :
        'This example filter on the first column in the range (change the field if needed)
        'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
        'Use "<>Netherlands" as criteria if you want the opposite
        My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"
    
        'If you want to filter on a cell value you can use this, use "<>" for the opposite
        'This example uses the activecell value
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value
    
        'This will use the cell value from A2 as criteria
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value
    
        ''If you want to filter on a Inputbox value use this
        'FilterCriteria = InputBox("What text do you want to filter on?", _
         '                              "Enter the filter item.")
        'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria
    
        'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
        CCount = 0
        On Error Resume Next
        CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
        On Error GoTo 0
        If CCount = 0 Then
            MsgBox "There are more than 8192 areas:" _
                 & vbNewLine & "It is not possible to copy the visible data." _
                 & vbNewLine & "Tip: Sort your data before you use this macro.", _
                   vbOKOnly, "Copy to worksheet"
        Else
            'Add a new Worksheet
            Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))
    
            'Ask for the Worksheet name
            sheetName = InputBox("What is the name of the new worksheet?", _
                                 "Name the New Sheet")
    
            On Error Resume Next
            WSNew.Name = sheetName
            If Err.Number > 0 Then
                MsgBox "Change the name of sheet : " & WSNew.Name & _
                     " manually after the macro is ready. The sheet name" & _
                     " you fill in already exists or you use characters" & _
                     " that are not allowed in a sheet name."
                Err.Clear
            End If
            On Error GoTo 0
    
            'Copy/paste the visible data to the new worksheet
            My_Range.Parent.AutoFilter.Range.Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                ' Remove this line if you use Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
    
            ' If you want to delete the rows that you copy, also use this
            ' With My_Range.Parent.AutoFilter.Range
            '     On Error Resume Next
            '     Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
            '               .SpecialCells(xlCellTypeVisible)
            '     On Error GoTo 0
            '     If Not rng Is Nothing Then rng.EntireRow.Delete
            ' End With
    
        End If
    
        'Close AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        'Restore ScreenUpdating, Calculation, EnableEvents, ....
        My_Range.Parent.Select
        ActiveWindow.View = ViewMode
        If Not WSNew Is Nothing Then WSNew.Select
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With
    
    End Sub
    
    
    Function LastRow(sh As Worksheet)
        On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", _
                                After:=sh.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlValues, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        On Error GoTo 0
    End Function

    Alternatively...

    Sub Copy_To_Workbooks()
    'Note: This macro use the function LastRow
        Dim My_Range As Range
        Dim FieldNum As Long
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim ws2 As Worksheet
        Dim MyPath As String
        Dim foldername As String
        Dim Lrow As Long
        Dim cell As Range
        Dim CCount As Long
        Dim WSNew As Worksheet
        Dim ErrNum As Long
    
        'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
        'and the header of the first column, D is the last column in the filter range.
        'You can also add the sheet name to the code like this :
        'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
        'No need that the sheet is active then when you run the macro when you use this.
        Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
        My_Range.Parent.Select
    
        If ActiveWorkbook.ProtectStructure = True Or _
           My_Range.Parent.ProtectContents = True Then
            MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                   vbOKOnly, "Copy to new workbook"
            Exit Sub
        End If
    
        'This example filters on the first column in the range(change the field if needed)
        'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
        FieldNum = 1
    
        'Turn off AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        'Set the file extension/format
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            If ActiveWorkbook.FileFormat = 56 Then
                FileExtStr = ".xls": FileFormatNum = 56
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        End If
    
        'Change ScreenUpdating, Calculation, EnableEvents, ....
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        ActiveSheet.DisplayPageBreaks = False
    
        'Delete the sheet RDBLogSheet if it exists
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("RDBLogSheet").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
    
        ' Add worksheet to copy/Paste the unique list
        Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
        ws2.Name = "RDBLogSheet"
    
        'Fill in the path\folder where you want the new folder with the files
        'you can use also this "C:\Users\Ron\test"
        MyPath = Application.DefaultFilePath
    
        'Add a slash at the end if the user forget it
        If Right(MyPath, 1) <> "\" Then
            MyPath = MyPath & "\"
        End If
    
        'Create folder for the new files
        foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
        MkDir foldername
    
        With ws2
            'first we copy the Unique data from the filter field to ws2
            My_Range.Columns(FieldNum).AdvancedFilter _
                    Action:=xlFilterCopy, _
                    CopyToRange:=.Range("A3"), Unique:=True
    
            'loop through the unique list in ws2 and filter/copy to a new sheet
            Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
            For Each cell In .Range("A4:A" & Lrow)
    
                'Filter the range
                My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                 Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
    
                'Check if there are no more then 8192 areas(limit of areas)
                CCount = 0
                On Error Resume Next
                CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                         .Areas(1).Cells.Count
                On Error GoTo 0
                If CCount = 0 Then
                    MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                         & vbNewLine & "It is not possible to copy the visible data." _
                         & vbNewLine & "Tip: Sort your data before you use this macro.", _
                           vbOKOnly, "Split in worksheets"
                Else
                    'Add new workbook with one sheet
                    Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    
                    'Copy/paste the visible data to the new workbook
                    My_Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNew.Range("A1")
                        ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                        ' Remove this line if you use Excel 97
                        .PasteSpecial Paste:=8
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With
    
                    'Save the file in the new folder and close it
                    On Error Resume Next
                    WSNew.Parent.SaveAs foldername & _
                                        cell.Value & FileExtStr, FileFormatNum
                    If Err.Number > 0 Then
                        Err.Clear
                        ErrNum = ErrNum + 1
    
                        WSNew.Parent.SaveAs foldername & _
                         "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
    
                        .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
                          "Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
    
                        .Cells(cell.Row, "A").Interior.Color = vbRed
                    Else
                        .Cells(cell.Row, "B").Formula = _
                        "=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
                    End If
    
                    WSNew.Parent.Close False
                    On Error GoTo 0
                End If
    
                'Show all the data in the range
                My_Range.AutoFilter Field:=FieldNum
    
            Next cell
            .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
            .Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
            .Cells(3, "A").Value = "Unique Values"
            .Cells(3, "B").Value = "Full Path and File name"
            .Cells(3, "A").Font.Bold = True
            .Cells(3, "B").Font.Bold = True
            .Columns("A:B").AutoFit
    
        End With
    
        'Turn off AutoFilter
        My_Range.Parent.AutoFilterMode = False
    
        If ErrNum > 0 Then
            MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
                 & vbNewLine & "There are characters in the name that are not allowed" _
                 & vbNewLine & "in a sheet name or the worksheet already exist."
        End If
    
        'Restore ScreenUpdating, Calculation, EnableEvents, ....
        My_Range.Parent.Select
        ActiveWindow.View = ViewMode
        ws2.Select
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With
    
    End Sub
    
    
    Function LastRow(sh As Worksheet)
        On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", _
                                After:=sh.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlValues, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        On Error GoTo 0
    End Function



    MY BOOK

    Tuesday, October 16, 2018 11:25 AM
  • Thank You Han for providing with the macro.

    I just tried it but have few issues

    This Macro is adding up column K correctly, but the totals appears in Column J instead of Column K.

    Secondly, My sorting requirement has changed from Column "C" and "D" to Column L and then Column B.

    I tried changing values in your below command by replacing C1 with L1 and D1 with B1, but for some reasons, header disappears. Can you please tell me how to fix this

     .UsedRange.Sort Key1:=Range("C1"), Key2:=Range("D1")

    Header issue: 

    Is it possible to bring all the header from A1: L10 in every sheet, at the moment it only bring one row i.e A10 : L10

    I will appreciate if you can help me out here.

    Tuesday, October 16, 2018 11:43 PM
  • 1. Change

    vcol = 10

    to

    vcol = 11

    2. Do you only want to sort rows 11 and down?


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, October 17, 2018 7:56 AM
  • Hi Hans

    I tried changing Vcol = 10 to Vcol = 11, but it creates infinite tabs with each values.

    (My data starts from row 11). Header rows are from 1 to 10.


    I want sorting based on column L first and column B second and sorting data from row 11 and down

    Thanks again for all your assistance so far

    Wednesday, October 17, 2018 11:01 PM
  • Here is a new version:

    Try this version:

    Sub parse_data()
        Dim LR As Long
        Dim ws As Worksheet
        Dim LR2 As Long
        Dim vcol, i As Integer
        Dim icol As Long
        Dim myarr As Variant
        Dim title As String
        Dim titlerow As Integer
        Application.ScreenUpdating = False
        vcol = 10
        Set ws = Sheets("Customer_statement")
        LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
        title = "A10:L10"
        titlerow = ws.Range(title).Cells(1).Row
        icol = ws.Columns.Count
        ws.Cells(1, icol) = "Unique"
        For i = 11 To LR
            On Error Resume Next
            If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
                ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
            End If
        Next
        myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
        ws.Columns(icol).Clear
        For i = 2 To UBound(myarr)
            ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
            If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
                Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
            Else
                Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
            End If
            ws.Range("A1:A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            With Sheets(myarr(i) & "")
                LR2 = .Cells(.Rows.Count, vcol).End(xlUp).Row
                Range("K" & LR2 + 1).Formula = "=SUM(K2:K" & LR2 & ")"
                .Range("A11:L" & LR2).Sort Key1:=Range("L11"), Key2:=Range("B11")
                .Columns.AutoFit
                Application.Goto .Range("C11")
                ActiveWindow.FreezePanes = True
            End With
        Next
        ws.AutoFilterMode = False
        ws.Activate
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, October 18, 2018 9:07 PM
  • It worked ... Thank you so much for helping out with this Hans . You are a Legend.
    Thursday, October 18, 2018 10:13 PM
  • Hi Hans,

    above code was great but would you be able to help me with a code, that can split the same data in different tab base on column G, without any header and save it in different excel file?

    Thanks

    Friday, January 18, 2019 9:40 PM
  • Do you want one workbook with a separate worksheet for each value in column G, or a separate workbook (with one worksheet) for each value in column G.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, January 18, 2019 9:44 PM
  • Do you want one workbook with a separate worksheet for each value in column G, or a separate workbook (with one worksheet) for each value in column G.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Ideally I would like to have separate work book for each value in column G without any header. Thanks.
    Tuesday, January 22, 2019 6:33 PM
  • I was thinking to have it separate in different tab and run another module to separate into different work book. If there is a way to separate the value in column G in separate workbook in one step it will be even better. Thanks
    Tuesday, January 22, 2019 6:34 PM
  • Gained an extra digit after your username? :)

    Here is a macro:

    Sub SplitData()
        Const NameCol = "G"
        Const FirstRow = 1
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Dim ThePath As String
        Dim i As Long
        Dim n As Long
        Application.ScreenUpdating = False
        n = Worksheets.Count
        ThePath = ActiveWorkbook.Path
        If Right(ThePath, 1) <> "\" Then
            ThePath = ThePath & "\"
        End If
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row
            If TrgSheet.Cells(TrgRow, NameCol).Value <> "" Then
                TrgRow = TrgRow + 1
            End If
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        For i = n + 1 To Worksheets.Count
            Worksheets(i).Copy
            ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
        Next i
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, January 22, 2019 9:31 PM
  • Thanks Han !!!!

    It won't let me login to my 123 account for some reasons, so I have to create another account to reply.

    the code works well, the header is gone now. It also created separated tab but it doesn't create separated work book. Do I need another Marco to separate tab into workbooks?

    Tuesday, January 22, 2019 10:05 PM
  • sorry I found it in my document. Can I change the location of the saved file to the same folder as my spreadsheet?
    Tuesday, January 22, 2019 10:12 PM
  • The code first creates new sheets, then saves them as separate workbooks:

        For i = n + 1 To Worksheets.Count
            Worksheets(i).Copy
            ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
        Next i


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, January 22, 2019 10:20 PM
  • Got it!!!! Thank you. one more request, is it possible to delete the column E, G and H in the same code

    I do not need column G anymore since the name is already shown on the file name.

    Also is it possible to convert the file to either .csv or txt format?

    I am sorry that I have so many questions, but I am very new to excel..

    Tuesday, January 22, 2019 10:28 PM
  • Here you go:

    Sub SplitData()
        Const NameCol = "G"
        Const FirstRow = 1
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Dim ThePath As String
        Dim i As Long
        Dim n As Long
        Application.ScreenUpdating = False
        n = Worksheets.Count
        ThePath = ActiveWorkbook.Path
        If Right(ThePath, 1) <> "\" Then
            ThePath = ThePath & "\"
        End If
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Student
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row
            If TrgSheet.Cells(TrgRow, NameCol).Value <> "" Then
                TrgRow = TrgRow + 1
            End If
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        For i = n + 1 To Worksheets.Count
            With Worksheets(i)
                .Range("G1:H1").EntireColumn.Delete
                .Range("E1").EntireColumn.Delete
                .Copy
            End With
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=ThePath & ActiveSheet.Name & ".csv", _
                FileFormat:=xlCSV
            ActiveWorkbook.Close SaveChanges:=False
            Application.DisplayAlerts = True
        Next i
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, January 22, 2019 10:42 PM
  • it works GREAT !!!! thank you very much for your help.=)
    Tuesday, January 22, 2019 10:53 PM
  • Hello Hans,

    After reading this thread, I can see that this code seems to be working for most people. 

    However, for me the code runs supposedly correctly at the beginning. I can see it creating the .xslx files based on the column values as intended. However, as the code finishes running, it saves the file in which the macro is located as a regular .xslx file, and gives it the names of one of the column values. After that, the supposedly created .xslx files with the column names are nowhere to be found. Have you ever encountered a similar problem, and would you perhaps know how to go about this? I am convinced that this code should be working for this Excel file as well, as no special characters are being used, and there seems to be nothing extra-ordinary about it.

    Kind regards,

    Koen

    Monday, August 26, 2019 1:08 PM
  • Hi Koen,

    In a very long thread such as this one, it is difficult to keep track of which version of the macro you refer to, but does the following work for you?

    Sub SplitData()
        Const NameCol = "A"
        Const HeaderRow = 1
        Const FirstRow = 2
        Dim i As Long
        Dim n As Long
        Dim SrcBook As Workbook
        Dim TrgBook As Workbook
        Dim SrcSheet As Worksheet
        Dim TrgSheet As Worksheet
        Dim SrcRow As Long
        Dim LastRow As Long
        Dim TrgRow As Long
        Dim Student As String
        Dim wbk As Workbook
        Dim ThePath As String
        Application.ScreenUpdating = False
        Set wbk = ActiveWorkbook
        ThePath = wbk.Path & "\"
        n = Worksheets.Count
        Set SrcSheet = ActiveSheet
        LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
        For SrcRow = FirstRow To LastRow
            Student = SrcSheet.Cells(SrcRow, NameCol).Value
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = wbk.Worksheets(Student)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = wbk.Worksheets.Add _
                    (After:=wbk.Worksheets(wbk.Worksheets.Count))
                TrgSheet.Name = Student
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        Next SrcRow
        Application.DisplayAlerts = False
        For i = wbk.Worksheets.Count To n + 1 Step -1
            Set TrgSheet = wbk.Worksheets(i)
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:=ThePath & TrgSheet.Name & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close
            TrgSheet.Delete
        Next i
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, August 26, 2019 2:13 PM