From data in an excel file, write new excel files populated with data based on a column's value

Question

I am essentially trying to slice my "master excel" file into a bunch of new files using the same data. I am able to create the new file, make an entry and then save; however, I am unable to add multiple entries into one file. I feel like I'm brain farting on some basic coding logic.

The master excel file looks as follows:

     A           B            C           D
1    XXX-01     100      Description1     4
2    XXX-01     104      Description2     2
3    XXX-01     209      Description3     3
4    XXX-02     102      Description4     5
5    XXX-02     355      Description5     1
6    XXX-02     322      Description6     1
7    XXX-02     943      Description7     9
8    XXX-02     231      Description8     4
9    XXX-03     124      Description9     4
10   XXX-03     555      Description10    2

Where A: GroupID B: Part_Number C: Description D: Quantity

My desire, from the above, would to make 3 excel files (XXX-01, XXX-02, XXX-03) where each file contains it's respective data.

For instance, XXX-01.xlsx would look like the following:

     A           B            C           D
1   Item#       Part      Description    Qty
2    1          100      Description1     4
3    2          104      Description2     2
4    3          209      Description3     3

Where row 1 is for headers that are the same for each XXX-## file.

In order to establish a baseline of where my code is at: the following works to create the file insert one row, but will then close and overwrite the previous file. (Stolen from: Create, name, and populate new workbook with data)

Sub CreateBooks()

    Dim oCell As Excel.Range
    Dim oWorkbook As Excel.Workbook

    Application.DisplayAlerts = False

    For Each oCell In Range("A:A")

        If oCell.Value = "" Then Exit For

        Set oWorkbook = Workbooks.Add

        oWorkbook.Sheets(1).Cells(1, 1).Value = oCell.Offset(0, 1).Value

        oWorkbook.Close True, oCell.Value

    Next oCell

    Application.DisplayAlerts = True

End Sub

I added the following in order to insert my save path into column A of the Master:

Dim Path As String
Path = "C:\Users\MyComputer\Documents" 

   For Each oCell In Range("A:A")

        If oCell.Value = "" Then Exit For

        oCell.Value = Path & oCell.Value

    Next oCell

My goal with the below edits was to get the for loop to repeat if the cell below oCell is equivalent to the value of oCell. Perhaps a Do While loop would be more applicable here; however.

Dim Row_Counter As Integer

For Each oCell In Range("A:A")

            If oCell.Value = "" Then Exit For

            Set oWorkbook = Workbooks.Add

            oWorkbook.Sheets(1).Cells(Row_Counter, 2).Value = oCell.Offset(0, 1).Value
            oWorkbook.Sheets(1).Cells(Row_Counter, 3).Value = oCell.Offset(0, 2).Value
            oWorkbook.Sheets(1).Cells(Row_Counter, 4).Value = oCell.Offset(0, 3).Value

            For Each Next_oCell In Range("A:A")

                If Next_oCell.Value = oCell.Value Then

                Row_Counter = Row_Counter + 1

                oWorkbook.Sheets(1).Cells(Row_Counter, 2).Value = Next_oCell.Offset(0, 1).Value
                oWorkbook.Sheets(1).Cells(Row_Counter, 3).Value = Next_oCell.Offset(0, 2).Value
                oWorkbook.Sheets(1).Cells(Row_Counter, 4).Value = Next_oCell.Offset(0, 3).Value

                End If

                Next Next_oCell

That being said, I am still only getting the one file that is being overwritten. I think my issue (or at least one of them) is that I don't have a means of saying "go through all rows with this value in column A, then skip to the first row with a new number."

Any help would be greatly appreciated!

Answer 1

Does this solution work?

Sub SeperateMasterFile()
'
' This part of the macro sorts Column A in Ascending Order

            Dim lRowD As Long
            Dim lRowA As Long


            'Find the last non-blank cell in column D(4)
            lRowD = Cells(Rows.Count, 4).End(xlUp).Row
        '
            'Find the last non-blank cell in column A(1)
            lRowA = Cells(Rows.Count, 1).End(xlUp).Row


            ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
            ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A1"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveWorkbook.Worksheets("Sheet1").Sort
                .SetRange Range("A1:D" & lRowD)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With


Dim LastI As Integer
Dim NewValueInColumnA As String
Dim NewValueInColumnARowNumber As Integer



For I = 1 To lRowA + 1

             LastI = I - 1



            'If LastI = 0 then we will make LastI = 1, because Range"(A0)".select would be invalid

            If LastI = 0 Then
            I = 1
            End If


            'When the For loop starts the following if statement
            'will put the value in A1 into the variable NewValueInColumnA

             If NewValueInColumnA = "" Then

                    NewValueInColumnA = Range("A1").Text
                    NewValueInColumnARowNumber = 1

             End If



             If NewValueInColumnA = Range("A" & I) Then

             Else

             'If A3 has a different value to A2, then the following code selects A1:D2
             'If A7 has a different value to A6, then the following code selects A3:D6

                     Range("A" & NewValueInColumnARowNumber & ":D" & LastI).Select
                     NewValueInColumnARowNumber = I
                     NewValueInColumnA = Range("A" & I)

                     'The following code now runs the macro called 'MoveToNewWorkBook'
                     Call MoveToNewWorkbook


             End If



Next I



End Sub
Sub MoveToNewWorkbook()
'
' MoveToNewWorkbook Macro
'



    Selection.Copy
    Workbooks.Add

    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    Range("A1").Value = "Item#"
    Range("B1").Value = "Part"
    Range("C1").Value = "Description"
    Range("D1").Value = "QTY"


    ActiveWorkbook.SaveAs Filename:="C:\Users\HP\Documents\" & Range("A2").Text & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

      ActiveWindow.Close

End Sub

Answer 2

Here's one approach:

Sub Divide()

    Dim dict As Object, v, k, c As Range, i As Long, sht As Worksheet

    Set dict = CreateObject("scripting.dictionary")

    'collect all the distinct values and matching cell references
    For Each c In Range("A:A")
        v = c.Value
        If Len(v) = 0 Then Exit For
        If Not dict.exists(v) Then dict.Add v, New Collection 'new key if needed
        dict(v).Add c 'add the cell to the appropriate collection
    Next c

    'process each group id in turn
    For Each k In dict.keys
        'create and save a workbook (to the same location as this workbook)
        With Workbooks.Add
            .SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
            .Sheets(1).Range("a1").Resize(1, 4).Value = _
                           Array("Item#", "Part", "Description", "Qty")
            i = 1
            'process each cell in the collection for this Group
            For Each c In dict(k)
                .Sheets(1).Cells(i + 1, 1).Value = i
                .Sheets(1).Cells(i + 1, 2).Resize(1, 3).Value = _
                           c.Offset(0, 1).Resize(1, 3).Value
                i = i + 1
            Next c
            .Close True 'save changes
        End With
    Next k

End Sub