Из данных в файле Excel напишите новые файлы Excel, заполненные данными на основе значения столбца.

Question

Я, по сути, пытаюсь нарезать мой файл «master excel» на кучу новых файлов, используя те же данные. Я могу создать новый файл, сделать запись и затем сохранить; Однако я не могу добавить несколько записей в один файл. Я чувствую, что у меня мозги пугают какой-то базовой логикой кодирования.

Основной файл Excel выглядит следующим образом:

     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

Где A: GroupID B: Part_Number C: Описание D: Количество

Исходя из вышесказанного, я хотел бы создать 3 файла Excel (XXX-01, XXX-02, XXX-03), в которых каждый файл содержит соответствующие данные.

Например, XXX-01.xlsx будет выглядеть следующим образом:

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

Где строка 1 для заголовков, которые одинаковы для каждого файла XXX - ##.

Чтобы установить базовый уровень того, где находится мой код: следующее работает для создания файла, вставьте одну строку, но затем закроете и перезапишите предыдущий файл. (Украдено из: Создание, имя и заполнение новой рабочей книги данными )

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

Я добавил следующее, чтобы вставить свой путь сохранения в столбец A Мастера:

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

Моя цель с приведенными ниже правками состояла в том, чтобы повторить цикл for, если ячейка ниже oCell эквивалентна значению oCell. Возможно, цикл Do While будет более уместным здесь; однако.

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

При этом я все еще получаю только один файл, который перезаписывается. Я думаю, что моя проблема (или, по крайней мере, одна из них) заключается в том, что у меня нет возможности сказать «пройти все строки с этим значением в столбце A, а затем перейти к первой строке с новым номером».

Любая помощь будет принята с благодарностью!

Answer 1

Вот один из подходов:

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

Answer 2

Работает ли это решение?

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