Loop or Advance Filter -VBA - Separate values into workbooks


I know this is a very common request, but I must be typing the wrong keywords into EE Search and  Google.

I have a list (table) of several hundred people and the hours they have worked (each date is one row). Each line has their employee number, name and hours worked (along with other fields). What I am trying to do is create a new workbook for each employee that list all the dates/hours they worked. This way, I can email them their own workbook without sending the master list to everyone.

I have looked for loops and advance filter VBA solutions to get me going, but most of them are created to make a list of the unique value out of the table.

Any links for help is greatly appreciated.

Thanks, Brent
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

I haven't tested this code, but it is something I found:

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
' Note: Values in the column should be unique or sorted.
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

    Dim osh As Worksheet    ' Original sheet
    Dim iRow As Long    ' Cursors
    Dim iCol As Long
    Dim iFirstRow As Long    ' Constant
    Dim iTotalRows As Long    ' Constant
    Dim iStartRow As Long    ' Section delimiters
    Dim iStopRow As Long
    Dim sSectionName As String    ' Section name (and filename)
    Dim rCell As Range    ' current cell
    Dim owb As Workbook    ' Original workbook
    Dim sFilePath As String    ' Constant
    Dim iCount As Integer    ' # of documents created

    iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
    iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
    iFirstRow = iRow

    Set osh = Application.ActiveSheet
    Set owb = Application.ActiveWorkbook
    iTotalRows = osh.UsedRange.Rows.Count
    sFilePath = Application.ActiveWorkbook.Path

    If Dir(sFilePath + "\Split", vbDirectory) = "" Then
        MkDir sFilePath + "\Split"
    End If

    'Turn Off Screen Updating  Events
    Application.EnableEvents = False
    Application.ScreenUpdating = False

        ' Get cell at cursor
        Set rCell = osh.Cells(iRow, iCol)
        sCell = Replace(rCell.Text, " ", "")

        If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
            ' Skip condition met
            ' Found new section
            If iStartRow = 0 Then
                ' StartRow delimiter not set, meaning beginning a new section
                sSectionName = rCell.Text
                iStartRow = iRow
                ' StartRow delimiter set, meaning we reached the end of a section
                iStopRow = iRow - 1

                ' Pass variables to a separate sub to create and save the new worksheet
                CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
                iCount = iCount + 1

                ' Reset section delimiters
                iStartRow = 0
                iStopRow = 0

                ' Ready to continue loop
                iRow = iRow - 1
            End If
        End If

        ' Continue until last row is reached
        If iRow < iTotalRows Then
            iRow = iRow + 1
            ' Finished. Save the last section
            iStopRow = iRow
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Exit
            Exit Do
        End If

    'Turn On Screen Updating  Events
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox Str(iCount) + " documents saved in " + sFilePath

End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

    Dim rngRange As Range
    Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow

End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
    Dim ash As Worksheet    ' Copied sheet
    Dim awb As Workbook    ' New workbook

' Copy book
    Set ash = Application.ActiveSheet

    ' Delete Rows after section
    If iTotalRows > iStopRow Then
        DeleteRows ash, iStopRow + 1, iTotalRows
    End If

    ' Delete Rows before section
    If iStartRow > iFirstRow Then
        DeleteRows ash, iFirstRow, iStartRow - 1
    End If

    ' Select left-topmost cell
    ash.Cells(1, 1).Select

    ' Clean up a few characters to prevent invalid filename
    sSectionName = Replace(sSectionName, "/", " ")
    sSectionName = Replace(sSectionName, "\", " ")
    sSectionName = Replace(sSectionName, ":", " ")
    sSectionName = Replace(sSectionName, "=", " ")
    sSectionName = Replace(sSectionName, "*", " ")
    sSectionName = Replace(sSectionName, ".", " ")
    sSectionName = Replace(sSectionName, "?", " ")

    ' Save in same format as original workbook
    ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

    ' Close
    Set awb = ash.Parent
    awb.Close SaveChanges:=False
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
bvanscoy678Author Commented:
I'll take a look. thanks. Post right back.
bvanscoy678Author Commented:
It worked perfect!

Thanks, Brent
bvanscoy678Author Commented:
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.