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