none
How to split data into multiple worksheets based on column in excel 2013 RRS feed

  • Question

  • Hi,

    How to split data into multiple worksheets based on column in excel 2013.

    i have searched it in google. they told you can do it in Enterprise Tab in excel, but i have not there in enterprise tab in my excel.

    this is my input.

    this is my output

    split the data based on name column in sheet1.

    Thanks 

    Abdul Khadir

    Sunday, February 5, 2017 1:30 PM

All replies

  • Preparation (needed only once):

    • Select File > Options.
    • Select 'Customize Ribbon' in the navigation pane on the left.
    • In the list of 'Main Tabs' on the right, tick the check box labeled Developer.
    • Click OK.

    Create a macro:

    • Activate the Developer tab of the ribbon.
    • Click 'Visual Basic'.
    • Select Insert > Module.
    • Copy the following code into the code module that appears:
    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Application.ScreenUpdating = False
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
                wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
                lngTargetRow = 2
            End If
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        Application.ScreenUpdating = True
    End Sub
    • Change the two constants at the beginning of the code as needed - lngNameCol is the number of the NAME column and lngFirstRow is the first row with data *excluding the header row)
    • Switch back to Excel.
    • Still on the Developer tab of the ribbon, click Macros.
    • Select SplitData, then click Run.

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

    Sunday, February 5, 2017 3:14 PM
  • Hi Abdul SQL,

    From the description of thread I understand that you are talking about "Enterprise" Tab.

    so I think that you visited the link mentioned below.

    How to split data into multiple worksheets based on column in Excel?

     what you had find is a Third Party Addin for Excel.

    it means if you want to use that functionality provided by that Addin then you have to install that Addin first.

    then you will see the "Enterprise" Tab.

    This Tab is not a by default tab that provided by MS Excel.

    This Addin name is Kutools.

    below is the link from where you can download it.

    Kutools for Excel

    Then you can follow the instruction mentioned in that link to split the data.

    Note:

    This is paid Addin. which means you need to purchase this Addin.

    They provide 60 days trial period. so you can try to download it and use it 60 days for free. then its up to you whether you purchase it or not.

    so from your above description it's looks like you want to use manual approach to split the data.

    but if you don't want to spend money then you can do this with VBA code for free.

    The VBA code is already provided in that link which I post below.

    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 = 1        
    Set ws = Sheets("Sheet1")        
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:C1"           
    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
    

    the instructions to use this code is also mentioned in the link which I posted above(The 1st link).

    This is a developer forum so we can only suggest you a code but if your requirement is to perform this task by user interface of Excel Application without using any third party Addin then let me know about that.

    I will move this thread to "Excel it pro discussions" Forum. where you can try get your answer.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, February 6, 2017 12:48 AM
    Moderator
  • Is there anyway to split the document copying more than one header line?
    Wednesday, June 27, 2018 11:33 AM
  • Wednesday, June 27, 2018 1:05 PM
  • This solution worked great for my application however, i have ran into a style/formatting issue. Before i ran the Macro I set the Master sheet for a Landscape printing orientation and set my column widths the way I want. However after I run the Macro the new sheets for the split data revert back to different column widths and Portrait orientation. 

    Is there a way to maintain the settings from the Master sheet to all of the "split data sheets"?

    Thursday, April 4, 2019 3:20 PM
  • Here is a slightly modified version:

    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Application.ScreenUpdating = False
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
                wshTarget.PageSetup.Orientation = xlLandscape
                wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Rows(lngFirstRow - 1).Copy
                wshTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = 2
            End If
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        Application.ScreenUpdating = True
    End Sub
    


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

    Thursday, April 4, 2019 9:32 PM
  • Thank you. It's getting closer. The new pages are set to print landscape so that's good. But I did not think to mention that i also have the Master to print gridlines and to fit all columns on one page. Any ideas to include these?
    • Edited by garmos Thursday, April 4, 2019 9:47 PM
    Thursday, April 4, 2019 9:46 PM
  • Change the line

                wshTarget.PageSetup.Orientation = xlLandscape

    to
                With wshTarget.PageSetup
                    .Orientation = xlLandscape
                    .PrintGridlines = True
                    .FitToPagesWide = 1
                End With


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

    Friday, April 5, 2019 8:48 AM
  • Thanks Hans, the orientation and grid lines held but the columns on one page didn't work. It still spills over into another page. Thoughts?
    Friday, April 5, 2019 3:53 PM
  • Sorry, I forgot one line

    Between With … and End With, insert the following line:

            .Zoom = False


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

    Friday, April 5, 2019 6:17 PM
  • Perfect!
    Friday, April 5, 2019 6:58 PM
  • Had everything working fine. Then this morning we ran it and we keep getting an error, "Run time error 1004: That name is already taken" When i select Debug, this line (which is bold and highlighted below) is highlighted in yellow. Thoughts?

    wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value

    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Application.ScreenUpdating = False
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
                With wshTarget.PageSetup
                    .Orientation = xlLandscape
                    .PrintGridlines = True
                    .FitToPagesWide = 1
                    .Zoom = False
                End With
                wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Rows(lngFirstRow - 1).Copy
                wshTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = 2
            End If
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        Application.ScreenUpdating = True
    End Sub

    Monday, April 8, 2019 9:02 PM
  • The code assumes that the name column (column B) has been sorted. If not, it will fail with the error message that you mention.

    If necessary, you could add code to sort the data before splitting them into sheets:

        wshSource.Cells(1, lngNameCol).CurrentRegion.Sort _
            Key1:=wshSource.Cells(1, lngNameCol), Header:=xlNo   


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


    Monday, April 8, 2019 9:33 PM
  • Thanks. That made the difference.
    Monday, April 8, 2019 9:47 PM
  • Hope i'm not pressing my luck with you - if i am just say so. Does the "sorting code" above get inserted into the "Sub Split" coding? If so, where? 

    Is there also a command so the newly created sheets have the same cell height and width and the same font size as the Master sheet? Some changes i make to the master transfer to the new sheets however some like cell height and font size don't.

    Tuesday, April 9, 2019 9:25 PM
  • Insert the sorting code below

        Set wshSource = ActiveSheet

    Copying all formatting would be a lot of work...


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

    Wednesday, April 10, 2019 6:01 AM
  • Preparation (needed only once):

    • Select File > Options.
    • Select 'Customize Ribbon' in the navigation pane on the left.
    • In the list of 'Main Tabs' on the right, tick the check box labeled Developer.
    • Click OK.

    Create a macro:

    • Activate the Developer tab of the ribbon.
    • Click 'Visual Basic'.
    • Select Insert > Module.
    • Copy the following code into the code module that appears:
    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Application.ScreenUpdating = False
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
                wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
                lngTargetRow = 2
            End If
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        Application.ScreenUpdating = True
    End Sub
    • Change the two constants at the beginning of the code as needed - lngNameCol is the number of the NAME column and lngFirstRow is the first row with data *excluding the header row)
    • Switch back to Excel.
    • Still on the Developer tab of the ribbon, click Macros.
    • Select SplitData, then click Run.

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

    Dear Hans, thank you very much, it helped me a lot in my work.

    Is it possible to add a code for automatic filter before splitting the sheets?

    Thank you in advance.

    Zivile

    Thursday, May 16, 2019 11:41 AM
  • What would you like to filter? Please provide detailed information.

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

    Thursday, May 16, 2019 12:02 PM
  • I mean every new split sheet would have a filter on the header row.

    Thursday, May 16, 2019 12:12 PM
  • Insert the following line above the line lngTargetRow = 2:

                wshTarget.UsedRange.AutoFilter


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

    Thursday, May 16, 2019 12:29 PM
  • Thank you very much. It worked perfectly.

    Zivile

    Thursday, May 16, 2019 12:48 PM
  • Great help Hans.

    I was wondering if we can split it into separate spreadheets?


    Wednesday, May 22, 2019 1:23 AM
  • Do you mean split into separate workbooks (files)?

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

    Wednesday, May 22, 2019 10:48 AM
  • yes separate work book.. thanks..
    Wednesday, May 22, 2019 11:59 PM
  • Here you go:

    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strName As String
        Application.ScreenUpdating = False
        strPath = ActiveWorkbook.Path & "\"
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                If lngRow > lngFirstRow Then
                    ' Save previous new workbook
                    wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
                    wbkTarget.Close
                End If
                ' Create new workbook
                Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
                Set wshTarget = wbkTarget.Worksheets(1)
                strName = wshSource.Cells(lngRow, lngNameCol).Value
                wshTarget.Name = strName
                wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
                lngTargetRow = 2
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Save last workbook
        wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
        wbkTarget.Close
        Application.ScreenUpdating = True
    End Sub


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

    Thursday, May 23, 2019 8:24 AM
  • You are LEGEND!!!

    Also can you please advise how can i keep top two rows as heading, and with formula, on all split workbooks?

    Friday, May 24, 2019 12:58 AM
  • Try this version:

    Sub SplitData()
         Const lngNameCol = 2 ' names in second column (B)
         Const lngFirstRow = 3 ' data start in row 3
         Dim wshSource As Worksheet
         Dim wbkTarget As Workbook
         Dim wshTarget As Worksheet
         Dim lngRow As Long
         Dim lngLastRow As Long
         Dim lngTargetRow As Long
         Dim strPath As String
         Dim strName As String
         Application.ScreenUpdating = False
         strPath = ActiveWorkbook.Path & "\"
         Set wshSource = ActiveSheet
         lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
         For lngRow = lngFirstRow To lngLastRow
             If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                 If lngRow > lngFirstRow Then
                     ' Save previous new workbook
                     wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
                     wbkTarget.Close
                 End If
                 ' Create new workbook
                 Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
                 Set wshTarget = wbkTarget.Worksheets(1)
                 strName = wshSource.Cells(lngRow, lngNameCol).Value
                 wshTarget.Name = strName
                 wshSource.Range("1:2").Copy Destination:=wshTarget.Cells(1, 1)
                 lngTargetRow = lngFirstRow
             End If
             ' Copy data
             wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
             lngTargetRow = lngTargetRow + 1
         Next lngRow
         ' Save last workbook
         wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
         wbkTarget.Close
         Application.ScreenUpdating = True
     End Sub


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

    Friday, May 24, 2019 7:53 AM
  • Thanks Hans.. It is great and working...only two things missing are same column width and size..and auto-filter from row 2... Can i add below two line to the coding?

                 wshTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths

                wshTarget.UsedRange.AutoFilter

    

    Sunday, May 26, 2019 11:00 PM
  • That should work.

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

    Monday, May 27, 2019 11:00 AM
  • Hello,

    I would like to thank you for all your replies. It helped me a lot with my work.

    I wanted to ask you, how can I change this code to have only one workbook with all the seperate sheets instead ofeach sheet in a different workbook ?

    Thank you in advance,

    Regards,

    Soukaina Ait taleb

    Monday, May 27, 2019 12:17 PM
  • Would you like to have all those worksheets in the same workbook as the original one, or together in a new workbook?

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

    Monday, May 27, 2019 1:19 PM
  • Dear Hans ,

    I didn't work i got debug error on wshTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths

    This put filter on first row but i needed on second row: wshTarget.UsedRange.AutoFilter

    Tuesday, May 28, 2019 4:47 AM
  • Try this version:

    Sub SplitData()
        Const lngNameCol = 2 ' names in second column (B)
        Const lngFirstRow = 3 ' data start in row 3
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strName As String
        Application.ScreenUpdating = False
        strPath = ActiveWorkbook.Path & "\"
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                If lngRow > lngFirstRow Then
                    ' Save previous new workbook
                    wshTarget.UsedRange.Offset(1).AutoFilter
                    wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
                    wbkTarget.Close
                End If
                ' Create new workbook
                Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
                Set wshTarget = wbkTarget.Worksheets(1)
                strName = wshSource.Cells(lngRow, lngNameCol).Value
                wshTarget.Name = strName
                wshSource.Range("1:2").Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Range("2:2").Copy
                wshTarget.Range("2:2").PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = lngFirstRow
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Save last workbook
        wshTarget.UsedRange.Offset(1).AutoFilter
        wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
        wbkTarget.Close
        Application.ScreenUpdating = True
    End Sub


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

    Tuesday, May 28, 2019 8:01 AM
  • worked perfect.. thanks again... i will join you website fr future forums- http://www.eileenslounge.com
    Tuesday, May 28, 2019 10:57 PM
  • Hi Hans, I think i am getting too much demanded lol.

    Is there a possibility of getting data into one spreadsheet from several spreadsheets?

    I can do that from several worksheet into one, but not sure if it can be done for spreadsheets too.

    Tuesday, June 25, 2019 11:56 PM
  • Please explain in more detail what you want to accomplish.

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

    Wednesday, June 26, 2019 9:52 AM
  • Hi Hans

    So i had a master file initially, which i split into several spreadsheets with the help of your program.

    Now i got updated several spreadsheets, which i want to put together into one single spreadsheet.

    Wednesday, June 26, 2019 10:58 PM
  • Do you want to combine data from ALL workbooks in a folder? Or just from some?

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

    Thursday, June 27, 2019 9:57 AM
  • In both scenarios,i.e., for all work books in a folder or just for some..
    Monday, July 1, 2019 10:42 PM
  • Here is a macro. When you run it, you'll be prompted to select the workbooks you want to combine. You can select multiple workbooks the same way as in File Explorer. To select all workbooks in a folder, select one workbook, then press Ctrl+A.

    Sub CombineFiles()
        Dim wbkS As Workbook
        Dim wshS As Worksheet
        Dim wbkT As Workbook
        Dim wshT As Worksheet
        Dim i As Long
        Dim r As Long
        Dim m As Long
        With Application.FileDialog(1) ' msoFileDialogOpen
            .Title = "Select the workbooks to be combined"
            .AllowMultiSelect = True
            .Filters.Clear
            .Filters.Add "Excel workbooks", "*.xls*"
            If .Show = False Then
                Beep
                Exit Sub
            End If
            Application.ScreenUpdating = False
            Set wbkT = Workbooks.Add(xlWBATWorksheet)
            Set wshT = wbkT.Worksheets(1)
            r = 1
            For i = 1 To .SelectedItems.Count
                Set wbkS = Workbooks.Open(Filename:=.SelectedItems(i), AddToMRU:=False)
                Set wshS = wbkS.Worksheets(1)
                m = wshS.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If i = 1 Then
                    wshS.Range("1:" & m).Copy Destination:=wshT.Range("A" & r)
                    r = r + m
                ElseIf m > 2 Then
                    wshS.Range("3:" & m).Copy Destination:=wshT.Range("A" & r)
                    r = r + m - 2
                End If
                wbkS.Close SaveChanges:=False
            Next i
            Application.ScreenUpdating = True
        End With
    End Sub


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

    Tuesday, July 2, 2019 8:25 AM
  • perfect, thanks!!!!
    Thursday, July 4, 2019 10:47 PM
  • Thank you so much for posting this. I am using this to combine several files  and have a question.. I only have 1 header row in my data and when the files are combined, I am losing the top row of data from each file. could you please help? 
    Saturday, July 20, 2019 10:09 PM
  • Thank you so much for posting this. I am using this to combine several files  and have a question.. I only have 1 header row in my data and when the files are combined, I am losing the top row of data from each file. could you please help? 

                ElseIf m > 1 Then
                    wshS.Range("2:" & m).Copy Destination:=wshT.Range("A" & r)
                    r = r + m - 1

    This seemed to work

    Saturday, July 20, 2019 10:15 PM
  • Hello,

    I know this an hold post but your macro is great!

    quick question, Could you have the macro to look if a workbook already exists, if so just copy data in that one, if not add new workbook?

    Thanks

    Thursday, September 12, 2019 2:59 PM
  • @Gazou ED: please explain in detail what you want.

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

    Thursday, September 12, 2019 7:53 PM
  • I figured it out, I have added Application.DisplayAlerts = False so it dosent ask if i want to save over the original document.

    What i would like for the macro to does thought is to add a new tab to the workbook instead of overwriting everything. any clues?

    I am using this code

    Sub SplitData()
    
    Application.Goto (ActiveWorkbook.Sheets("Control Sheet").Range("E6"))
    
        Const lngNameCol = 3 ' names in second column (c)
        Const lngFirstRow = 2 ' data start in row 3
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strName As String
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        strPath = ActiveWorkbook.Path & "\"
        Set wshSource = ActiveSheet
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                If lngRow > lngFirstRow Then
                    ' Save previous new workbook
                    wshTarget.UsedRange.Offset(1).AutoFilter
                    wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
                    wbkTarget.Close
                End If
                ' Create new workbook
                Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
                Set wshTarget = wbkTarget.Worksheets(1)
                strName = wshSource.Cells(lngRow, lngNameCol).Value
                wshTarget.Name = strName
                wshSource.Range("1:2").Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Range("2:2").Copy
                wshTarget.Range("2:2").PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = lngFirstRow
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Save last workbook
        wshTarget.UsedRange.Offset(1).AutoFilter
        wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
        wbkTarget.Close
        Application.ScreenUpdating = True
    End Sub
    

    Tuesday, September 17, 2019 3:24 PM
  • This code creates a workbook for each unique value in the column specified by lngNameCol. Would you like to add worksheets to the current workbook instead? Or would you like to add worksheets to a single new workbook? Or something else?

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

    Tuesday, September 17, 2019 3:29 PM
  • I want it to do exactly what its doing but if workbook exist, just copy data to a new tab in that existing WB.

    So basically, first time i run it, it creates new workbooks, and the next times adds a new tab to existing document.

    Tuesday, September 17, 2019 3:40 PM
  • In the current code, the worksheet name in the new workbook is the value from column C. We cannot add a new worksheet with the same name. How should we name the new worksheet?

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

    Tuesday, September 17, 2019 6:22 PM
  • How about today's date? would that be possible?
    Tuesday, September 17, 2019 7:08 PM
  • Here is a modified macro:

    Sub SplitData()
        Const lngNameCol = 3 ' names in third column (C)
        Const lngFirstRow = 2 ' data start in row 2
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strName As String
        Dim f As Boolean
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        strPath = ActiveWorkbook.Path & "\"
        Set wshSource = Worksheets("Control Sheet")
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
                If lngRow > lngFirstRow Then
                    wshTarget.UsedRange.Offset(1).AutoFilter
                    If f Then
                        ' Save existing workbook
                        wbkTarget.Close SaveChanges:=True
                    Else
                        ' Save new workbook
                        wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
                        wbkTarget.Close
                    End If
                End If
                strName = wshSource.Cells(lngRow, lngNameCol).Value
                If Dir(strPath & strName) <> "" Then
                    f = True
                    ' Open existing workbook
                    Set wbkTarget = Workbooks.Open(strPath & strName)
                    Set wshTarget = wbkTarget.Worksheets.Add(After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count))
                Else
                    f = False
                    ' Create new workbook
                    Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
                    Set wshTarget = wbkTarget.Worksheets(1)
                End If
                wshTarget.Name = Format(Date, "yyyy_mm_dd")
                wshSource.Range("1:2").Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Range("2:2").Copy
                wshTarget.Range("2:2").PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = lngFirstRow
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Save last workbook
        wshTarget.UsedRange.Offset(1).AutoFilter
        If f Then
            ' Save existing workbook
            wbkTarget.Close SaveChanges:=True
        Else
            ' Save new workbook
            wbkTarget.SaveAs Filename:=strPath & strName, FileFormat:=xlOpenXMLWorkbook
            wbkTarget.Close
        End If
        Application.ScreenUpdating = True
    End Sub


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

    Tuesday, September 17, 2019 7:36 PM
  • Good morning Sir!

    I unfortunately get a Run-Time error '1004' when it has copied all data into new sheets, it seems to continue when theirs no more data and i get this error message.

    'C:\Users\Name\Desktop\New Folder\' Could not be found. Check the spelling of the file name, and verify that the file location is correct.

    Any clue how to fix this?

    Thanks

    Eric


    Thursday, September 19, 2019 11:23 AM
  • Immediately below the line

       For lngRow = lngFirstRow To lngLastRow

    insert the following:

          If Trim(wshSource.Cells(lngRow, lngNameCol).Value) = "" Then Exit For


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


    Thursday, September 19, 2019 12:25 PM
  • Hello Hans Vogelaar!

    I have a unique problem for which I'm looking a unique solution. Your VBA code accomplishes the job 50%. Here's the problem; I have a worksheet that has a columns for Store Locations and a Column for Owner. Other columns are for sales/inventory values, etc. Data is about 300,000 rows. I'm trying to come up with a VBA Code/Macro that will create new workbooks based on Owner column and within that workbook it splits the data into multiple worksheets based on store locations. For example; there is a owner in the list named David Hogg who has 3 store locations; Location 1, Location 2, Locations 3. The code should create and save a new workbook named as "David Hogg" and within that workbook should create 3 worksheets named as "Location 1", "Locations 2", and "Location 3". If it can attach those individual workbooks to an outlook email and take the email address from the column Email Address in the original worksheet, that would be great! Do you think that's possible? I have been doing this manually and it's a super pain!! Any help will be greatly appreciated!

    Regards, 

    Roger

    Tuesday, September 24, 2019 2:16 PM
  • @Roger Dale: are the data sorted by owner, and by location for each owner?

    If not, would it be OK to sort the data that way before creating the workbooks?


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

    Tuesday, September 24, 2019 8:02 PM
  • @Hans Vogelaar, No, the data is not sorted by owner and by location. So yes, it would be OK to sort the data that way before creating the workbooks! Thanks a bunch!!
    Tuesday, September 24, 2019 8:25 PM
  • Here is a macro. I fear that it will be excruciatingly slow with 300,000 rows...

    You'll have to modify the constants at the beginning, as well as the values of strSubject and strBody.

    Sub SplitData()
        ' Modify these constants as needed
        Const strSheet = "DataSheet" ' name of the sheet with the data
        Const lngOwnerCol = 3        ' owner names in third column (C)
        Const lngLocationCol = 5     ' locations in fifth column (E)
        Const lngEmailCol = 9        ' email addresses in ninth column (I)
        Const lngFirstRow = 2        ' data start in row 2
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strFile As String
        Dim strOwner As String
        Dim strLocation As String
        Dim strEmail As String
        Dim strSubject As String
        Dim strBody As String
        Dim objOL As Object
        Dim objMsg As Object
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Set objOL = CreateObject(Class:="Outlook.Application")
        strPath = ActiveWorkbook.Path & "\"
        strSubject = "This is the subject"
        strBody = "Please see the attached workbook."
        Set wshSource = Worksheets(strSheet)
        wshSource.Cells(lngFirstRow, lngOwnerCol).CurrentRegion.Sort _
            Key1:=wshSource.Cells(lngFirstRow, lngOwnerCol), _
            Key2:=wshSource.Cells(lngFirstRow, lngLocationCol), _
            Header:=xlYes
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngOwnerCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngOwnerCol).Value <> strOwner Then
                If lngRow > lngFirstRow Then
                    ' Send new workbook
                    wbkTarget.Worksheets(1).Delete
                    wbkTarget.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
                    wbkTarget.Close SaveChanges:=False
                    Set objMsg = objOL.CreateItem(0)
                    objMsg.To = strEmail
                    objMsg.Subject = strSubject
                    objMsg.Body = strBody
                    objMsg.Attachments.Add strFile
                    objMsg.Display ' or .Send
                End If
                strOwner = wshSource.Cells(lngRow, lngOwnerCol).Value
                strFile = strPath & strOwner & ".xlsx"
                strEmail = wshSource.Cells(lngRow, lngEmailCol).Value
                strLocation = ""
                Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
            End If
            If wshSource.Cells(lngRow, lngLocationCol) <> strLocation Then
                strLocation = wshSource.Cells(lngRow, lngLocationCol)
                Set wshTarget = wbkTarget.Worksheets.Add _
                    (After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count))
                wshTarget.Name = strLocation
                wshSource.Cells(lngFirstRow - 1).EntireRow.Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Cells(lngFirstRow - 1).EntireRow.Copy
                wshTarget.Cells(1, 1).EntireRow.PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = 2
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Send last new workbook
        wbkTarget.Worksheets(1).Delete
        wbkTarget.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
        wbkTarget.Close SaveChanges:=False
        Set objMsg = objOL.CreateItem(0)
        objMsg.To = strEmail
        objMsg.Subject = strSubject
        objMsg.Body = strBody
        objMsg.Attachments.Add strFile
        objMsg.Display ' or .Send
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


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

    • Proposed as answer by Roger Dale Tuesday, September 24, 2019 10:35 PM
    Tuesday, September 24, 2019 9:54 PM
  • Thank you, Sir! I just looked at the Macro. I haven't tested it yet but I did take notice of your comment, "I fear that it will be excruciatingly slow with 300,000 rows...". Do you think there's a better way to do it? Like in Access? Or Access and Excel combined? I'm pretty good at Access, making tables, creating queries, running simple Macros, it's just the VBA part I'm not so good at. 

    Regards, Roger

    Tuesday, September 24, 2019 9:59 PM
  • Creating queries in an Access database that return the data for a specific owner and location would be very easy, but creating a workbook for each owner, with a sheet for each location would still be a lot of work...

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

    Wednesday, September 25, 2019 6:47 AM
  • Hans,

    Understood...

    I tested the Macro last night and this morning as well. Here's the weird thing; it worked fine a couple times during the testing but majority of the time it kept running in this error; 

    Run-time error '-2147417856 (80010100)':

    Automation error

    System call failed.

    When I hit Debug, it highlights the following line in yellow; 

    Set objMsg = objOL.CreateItem(0)

    If I click on End at run time error window and try again running the macro without closing the Excel file, it works. But if I close the Excel file and run the macro from the start, it runs into the same error. Do you know what's causing this?

    Wednesday, September 25, 2019 1:54 PM
  • That's strange. Does it work better if you start Outlook before running the macro?

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

    Wednesday, September 25, 2019 2:36 PM
  • I ran into this error while Outlook was already running. I just closed the Outlook and ran the Macro again and ran into the same issue...
    Wednesday, September 25, 2019 2:55 PM
  • I'm afraid I don't have an explanation - the code ran without error in the sample workbook that I created to test it.

    If you wish, you could create a (small!) sample workbook without sensitive information that demonstrates the problem, and make it available through DropBox, Google Drive, OneDrive or similar.


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

    Wednesday, September 25, 2019 6:29 PM
  • Sure. Here's the link to the file. 

    https://www.dropbox.com/s/hsby393je23ewk6/Macro%20Test.xlsm?dl=0

    Wednesday, September 25, 2019 7:15 PM
  • Thanks - that helped to pinpoint the error. The following version runs without error for me, but it is much too slow to be used for a large worksheet...

    Sub SplitData()
        ' Modify these constants as needed
        Const strSheet = "Data" ' name of the sheet with the data
        Const lngOwnerCol = 19        ' owner names in column S
        Const lngLocationCol = 3     ' locations in column C
        Const lngEmailCol = 21        ' email addresses in column U
        Const lngFirstRow = 2        ' data start in row 2
        Dim wshSource As Worksheet
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strFile As String
        Dim strOwner As String
        Dim strLocation As String
        Dim strEmail As String
        Dim strSubject As String
        Dim strBody As String
        Dim objOL As Object
        Dim objMsg As Object
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Set objOL = CreateObject(Class:="Outlook.Application")
        strPath = ActiveWorkbook.Path & "\"
        strSubject = "This is the subject"
        strBody = "Please see the attached workbook."
        Set wshSource = Worksheets(strSheet)
        wshSource.Cells(lngFirstRow, lngOwnerCol).CurrentRegion.Sort _
            Key1:=wshSource.Cells(lngFirstRow, lngOwnerCol), _
            Key2:=wshSource.Cells(lngFirstRow, lngLocationCol), _
            Header:=xlYes
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngOwnerCol).End(xlUp).Row
        For lngRow = lngFirstRow To lngLastRow
            If wshSource.Cells(lngRow, lngOwnerCol).Value <> strOwner Then
                If lngRow > lngFirstRow Then
                    ' Send new workbook
                    wbkTarget.Worksheets(1).Delete
                    wbkTarget.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
                    wbkTarget.Close SaveChanges:=False
                    DoEvents
                    Set objMsg = objOL.CreateItem(0)
                    objMsg.To = strEmail
                    objMsg.Subject = strSubject
                    objMsg.Body = strBody
                    objMsg.Attachments.Add strFile
                    objMsg.Display ' or .Send
                End If
                strOwner = wshSource.Cells(lngRow, lngOwnerCol).Value
                strFile = strPath & strOwner & ".xlsx"
                strEmail = wshSource.Cells(lngRow, lngEmailCol).Value
                strLocation = ""
                Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
            End If
            If wshSource.Cells(lngRow, lngLocationCol) <> strLocation Then
                strLocation = wshSource.Cells(lngRow, lngLocationCol)
                Set wshTarget = wbkTarget.Worksheets.Add _
                    (After:=wbkTarget.Worksheets(wbkTarget.Worksheets.Count))
                wshTarget.Name = strLocation
                wshSource.Cells(lngFirstRow - 1).EntireRow.Copy Destination:=wshTarget.Cells(1, 1)
                wshSource.Cells(lngFirstRow - 1).EntireRow.Copy
                wshTarget.Cells(1, 1).EntireRow.PasteSpecial Paste:=xlPasteColumnWidths
                lngTargetRow = 2
            End If
            ' Copy data
            wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
            lngTargetRow = lngTargetRow + 1
        Next lngRow
        ' Send last new workbook
        wbkTarget.Worksheets(1).Delete
        wbkTarget.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
        wbkTarget.Close SaveChanges:=False
        DoEvents
        Set objMsg = objOL.CreateItem(0)
        objMsg.To = strEmail
        objMsg.Subject = strSubject
        objMsg.Body = strBody
        objMsg.Attachments.Add strFile
        objMsg.Display ' or .Send
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


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


    Wednesday, September 25, 2019 8:08 PM
  • Thanks Hans -- Sorry for the late reply. I have been testing the above Macro for days to see if it will work for me. Unfortunately, you're correct to say that it's much too slow. So I have dropped the idea to split the data into multiple worksheets. I think I'd like to go with the approach that we split the master data based on owner column into multiple workbooks only, not sheets, and attach those workbooks in email using the email address tied to that owner in Email Adddress column. For that to make happen, what changes do I need to make in the Macro? I'm sorry for troubling you again, but I'm afraid I'll completely destroy the code if I messed with it!
    Wednesday, October 9, 2019 7:21 PM
  • That would suffer from the same problem. If you really need to work with such a large dataset, I'd move it to a database: Microsoft Access, or SQL Server.

    Database queries are a much more efficient way to do this.


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

    Wednesday, October 9, 2019 7:52 PM
  • So initially, we were going to do this for a long list of owners, but we have trimmed down the list to only 4 owners with a total of 50 locations. I think we might make it work with an Excel Macro for now.
    Wednesday, October 9, 2019 8:02 PM
  • Try this new version:

    Sub SplitData()
        ' Modify these constants as needed
        Const strSheet = "Data" ' name of the sheet with the data
        Const lngOwnerCol = 19  ' owner names in column S
        Const lngEmailCol = 21  ' email addresses in column U
        Const lngFirstRow = 2   ' data start in row 2
        Const lngExtraCol = 100 ' an arbitrary column beyond the data
        Dim wshSource As Worksheet
        Dim rngSource As Range
        Dim wbkTarget As Workbook
        Dim wshTarget As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngTargetRow As Long
        Dim strPath As String
        Dim strFile As String
        Dim strOwner As String
        Dim strEmail As String
        Dim strSubject As String
        Dim strBody As String
        Dim objOL As Object
        Dim objMsg As Object
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Set objOL = CreateObject(Class:="Outlook.Application")
        strPath = ActiveWorkbook.Path & "\"
        strSubject = "This is the subject"
        strBody = "Please see the attached workbook."
        Set wshSource = Worksheets(strSheet)
        ' Create a range with unique owners
        wshSource.Cells(lngFirstRow - 1, lngExtraCol).Value = _
            wshSource.Cells(lngFirstRow - 1, lngOwnerCol).Value
        wshSource.Cells(lngFirstRow - 1, lngExtraCol + 1).Value = _
            wshSource.Cells(lngFirstRow - 1, lngEmailCol).Value
        Set rngSource = wshSource.Cells(lngFirstRow, lngOwnerCol).CurrentRegion
        rngSource.AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=wshSource.Cells(1, lngExtraCol).Resize(1, 2), _
            Unique:=True
        ' Loop through the unique owner names
        lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngExtraCol).End(xlUp).Row
        For lngRow = 2 To lngLastRow
            strOwner = wshSource.Cells(lngRow, lngExtraCol).Value
            strFile = strPath & strOwner & ".xlsx"
            strEmail = wshSource.Cells(lngRow, lngExtraCol + 1).Value
            ' Filter the source data
            rngSource.AutoFilter Field:=lngOwnerCol, _
                Criteria1:=wshSource.Cells(lngRow, lngExtraCol).Value
            ' Create new workbook
            Set wbkTarget = Workbooks.Add(xlWBATWorksheet)
            Set wshTarget = wbkTarget.Worksheets(1)
            wshTarget.Name = strOwner
            ' Copy filtered data
            rngSource.SpecialCells(xlCellTypeVisible).Copy Destination:=wshTarget.Cells(1, 1)
            ' Copy column widths
            wshSource.Cells(lngFirstRow - 1).EntireRow.Copy
            wshTarget.Cells(1, 1).EntireRow.PasteSpecial Paste:=xlPasteColumnWidths
            ' Save new workbook
            wbkTarget.SaveAs Filename:=strFile, FileFormat:=xlOpenXMLWorkbook
            wbkTarget.Close SaveChanges:=False
            DoEvents
            ' Create email message
            Set objMsg = objOL.CreateItem(0)
            objMsg.To = strEmail
            objMsg.Subject = strSubject
            objMsg.Body = strBody
            objMsg.Attachments.Add strFile
            objMsg.Display ' or .Send
        Next lngRow
        wshSource.Cells(1, lngExtraCol).Resize(lngLastRow, 2).Clear
        wshSource.ShowAllData
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


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

    Wednesday, October 9, 2019 9:43 PM
  • Hans, This worked like a CHARM!!! Big Thanks! Appreciate your help! 
    Tuesday, October 15, 2019 3:54 PM