Page 1 of 2 12 LastLast
Results 1 to 10 of 18

Thread: 10$ For VBA Code Split Data To Multiple Workbook Based On Unique Values In A Column

  1. #1
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0

    10$ For VBA Code Split Data To Multiple Workbook Based On Unique Values In A Column

    I have a Worksheet which I want to split to separate workbooks for each ProjectNumber. and I want the .xlsb files for each to be save with projectnumber and the original file name.

    the projectnumber column is Column P

    I would like an .xlsb file for each with only the records for projectNumber 1#####, projectnumber 1#####, and so on.

    What VBA code would I use to do this?

    Similarly in reverse

    i would like another code to be able to combine all of these saved seperate workbooks and merge them all into one worksheet as it was in the first place.


    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA



    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg. 9gJzxwFcnPU9gORqKw5tW_
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://eileenslounge.com/viewtopic.php?p=316705#p316705
    https://eileenslounge.com/viewtopic.php?p=316704#p316704
    https://eileenslounge.com/viewtopic.php?f=27&t=40919&p=316597#p316597
    https://eileenslounge.com/viewtopic.php?p=316412#p316412
    https://eileenslounge.com/viewtopic.php?p=316254#p316254
    https://eileenslounge.com/viewtopic.php?p=316280#p316280
    https://eileenslounge.com/viewtopic.php?p=315915#p315915
    https://eileenslounge.com/viewtopic.php?p=315512#p315512
    https://eileenslounge.com/viewtopic.php?p=315744#p315744
    https://www.eileenslounge.com/viewtopic.php?p=315512#p315512
    https://eileenslounge.com/viewtopic.php?p=315680#p315680
    https://eileenslounge.com/viewtopic.php?p=315743#p315743
    https://www.eileenslounge.com/viewtopic.php?p=315326#p315326
    https://www.eileenslounge.com/viewtopic.php?f=30&t=40752
    https://eileenslounge.com/viewtopic.php?p=314950#p314950
    https://www.eileenslounge.com/viewtopic.php?p=314940#p314940
    https://www.eileenslounge.com/viewtopic.php?p=314926#p314926
    https://www.eileenslounge.com/viewtopic.php?p=314920#p314920
    https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 04-24-2024 at 07:27 PM.

  2. #2
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    [CODE]file is uploaded here https://skydrive.live.com/redir?resid=D7C00A2BF29043E0!257



    for the spliting part code. i have found the following code from search and it somehow does not work. perhaps needs some

    Code:
    Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String)
    If colLetter = "" Then colLetter = "P"
    Dim lastValue As String
    Dim hasHeader As Boolean
    Dim wb As Workbook
    Dim c As Range
    Dim currentRow As Long
    hasHeader = True 'Indicate true or false depending on if sheet  has header row.
    
    If SavePath = "" Then SavePath = ThisWorkbook.Path
    'Sort the workbook.
    ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ThisWorkbook.Worksheets(1).Sort
        .SetRange Cells
        If hasHeader Then ' Was a header indicated?
            .Header = xlYes
        Else
            .Header = xlNo
        End If
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For Each c In ThisWorkbook.Sheets(1).Range("P:P")
        If c.Value = "" Then Exit For
        If c.Row = 1 And hasHeader Then
        Else
            If lastValue <> c.Value Then
                If Not (wb Is Nothing) Then
                    wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
                    wb.Close
                End If
                lastValue = c.Value
                currentRow = 1
                Set wb = Application.Workbooks.Add
            End If
            ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy
            wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
            wb.Sheets(1).Paste
    
        End If
    Next
    If Not (wb Is Nothing) Then
        wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
        wb.Close
    End If
    End Sub

  3. #3
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    i also worked out this code but it creates the workbooks but somehow some of the data is missing on those created workbooks

    Code:
    Sub DistributeRowsToNewWBS()
    Dim wbNew As Workbook
    Dim wsData As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim rngCrit As Range
    Dim LastRow As Long
        
        Set wsData = Worksheets("Expenditure_Details") ' name of worksheet with the data
        Set wsCrit = Worksheets.Add
        
        LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
        
        ' column H has the criteria
        wsData.Range("p1:p" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
        
        Set rngCrit = wsCrit.Range("A2")
        While rngCrit.Value <> ""
            Set wsNew = Worksheets.Add
            ' change E to reflect columns to copy
            wsData.Range("A1:bp" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
            wsNew.Name = rngCrit
            wsNew.Copy
            Set wbNew = ActiveWorkbook
            ' saves new workbook in path of existing workbook
            wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
            wbNew.Close SaveChanges:=True
            Application.DisplayAlerts = False
            wsNew.Delete
            rngCrit.EntireRow.Delete
            Set rngCrit = wsCrit.Range("A2")
        Wend
        
        wsCrit.Delete
        Application.DisplayAlerts = True
        
    End Sub

  4. #4
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    please let me know if this is possible, otherwise, please delete the thread. thanks.

  5. #5
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Here's the code. Run this from within the source workbook

    Code:
    Sub SplitWorkbook()
    
        Dim colLetter As String, SavePath As String
        Dim lastValue As String
        Dim wb As Workbook
        Dim lng As Long
        Dim currentRow As Long
        colLetter = "P"
        SavePath = "" 'Indicate the path to save
        If SavePath = "" Then SavePath = ThisWorkbook.Path
        'Sort the workbook.
        With ThisWorkbook.Worksheets(1)
            .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Cells
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
                If .Cells(lng, colLetter).Value = "" Then Exit For
                lastValue = .Cells(lng, colLetter).Value
                .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
                lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
                Set wb = Application.Workbooks.Add(xlWorksheet)
                .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
                wb.SaveAs SavePath & "\" & lastValue, 50
                wb.Close
            Next
            .AutoFilterMode = False
        End With
        
    End Sub
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  6. #6
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    Capture.JPG
    this code did not work. it gives two errors one. worksheet error

    and also vba run time error 1004 debugger stops at with Sort .apply
    Last edited by Excel Fox; 05-22-2013 at 10:33 PM. Reason: Removed Quote

  7. #7
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Works absolutely fine at my side. For the resources issue, try restarting your computer, and then run the code.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  8. #8
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    I get 43 xlsb files as output
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  9. #9
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    Capture.JPG
    i restarted and tried again. still get the same error. also the runtime error


    do i need to add any reference from the object library?



    Code:
    Sub SplitWorkbook()
    
        Dim colLetter As String, SavePath As String
        Dim lastValue As String
        Dim wb As Workbook
        Dim lng As Long
        Dim currentRow As Long
        colLetter = "P"
        SavePath = "" 'Indicate the path to save
        If SavePath = "" Then SavePath = ThisWorkbook.Path
        'Sort the workbook.
        With ThisWorkbook.Worksheets(1)
            .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Cells
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
                If .Cells(lng, colLetter).Value = "" Then Exit For
                lastValue = .Cells(lng, colLetter).Value
                .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
                lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
                Set wb = Application.Workbooks.Add(xlWorksheet)
                .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
                wb.SaveAs SavePath & "\" & lastValue, 50
                wb.Close
            Next
            .AutoFilterMode = False
        End With
        
    End Sub
    Quote Originally Posted by Excel Fox View Post
    I get 43 xlsb files as output

  10. #10
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    what version excel r u using?
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

Similar Threads

  1. Replies: 10
    Last Post: 05-23-2013, 12:30 PM
  2. Replies: 4
    Last Post: 05-01-2013, 09:49 PM
  3. Replies: 2
    Last Post: 04-14-2013, 09:15 PM
  4. Replies: 2
    Last Post: 03-05-2013, 07:34 AM
  5. Group Pivot Data Based On Row Values In One Column
    By mrmmickle1 in forum Excel Help
    Replies: 10
    Last Post: 10-09-2012, 11:46 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •