VBA - Split row by quantity by values

Question

I am currently trying to split up a row by its quantity then update the "picked" value to reflect this,

For example Product A has a QTY of 5, so 5 lines should be created. Only 3 of these have been picked, so the first 3 new lines can have a picked value of 1, whereas the final 2 lines need to be 0.

Input

Desired Output

I've used an existing VBA script that can do the first part but it's not able to do part 2 (picked). This script simply creates duplicate lines based on the QTY value, but isnt able to manipulate the picked values before insert. So I'm a bit stuck, hopefully someone can help? I appreciate this may need a total rewrite.

Sub CopyData()
'Updateby Extendoffice
    Dim xRow As Long
    Dim VInSertNum As Variant
    Dim Start As Long
    xRow = 2
    Application.ScreenUpdating = False
    Do While (Cells(xRow, "A") <> "")
        VInSertNum = Cells(xRow, "B")
        Cells(xRow, "B").Value = 1
        If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
           Range(Cells(xRow, "A"), Cells(xRow, "H")).Copy
           Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "H")).Select
           Selection.Insert Shift:=xlDown
           xRow = xRow + VInSertNum - 1
        End If
    xRow = xRow + 1
    Loop
    Application.ScreenUpdating = False
End Sub

Incorrect Output

EDIT ---------------_

Thank you for the help, I've tried to adjust the code you sent for the final data but it's not quite working for me, In the final sheet column 8,9,10 are what is discussed above - with data that just needs to be copied either side, what am I missing?

Sub TestMacro()

Dim i As Long
    Dim lr As Long
    Dim dict As Object
    Dim temparr As Variant 'For duplicates
    Dim newsheet As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    With Sheets("ExchequerReport") 'Change as needed
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            If Not dict.exists(.Cells(i, 8).Value) Then
                dict.Add .Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value, .Cells(i, 4).Value, .Cells(i, 5).Value, .Cells(i, 6).Value, .Cells(i, 7).Value, .Cells(i, 8).Value, Array(.Cells(i, 9).Value.Cells(i, 10).Value.Cells(i, 11).Value.Cells(i, 12).Value.Cells(i, 13).Value.Cells(i, 14).Value.Cells(i, 15).Value.Cells(i, 16).Value.Cells(i, 17).Value.Cells(i, 18).Value.Cells(i, 19).Value.Cells(i, 20).Value.Cells(i, 21).Value)
            Else
                'Not sure what to do about dupes, adding quantities together
                temparr = dict(.Cells(i, 8).Value)
                temparr(0) = dict(.Cells(i, 8).Value)(0) + .Cells(i, 9).Value
                temparr(1) = dict(.Cells(i, 8).Value)(1) + .Cells(i, 10).Value
                dict(.Cells(i, 1).Value) = temparr
            End If
        Next i
    End With
    
    Set newsheet = ThisWorkbook.Sheets.Add
    
    With newsheet
        Dim key As Variant
        Dim j As Long
        .Cells(1, 1).Value = "Model Helper"
        .Cells(1, 2).Value = "Dealer Helper"
        .Cells(1, 3).Value = "Account Code"
        .Cells(1, 4).Value = "Dealer"
        .Cells(1, 5).Value = "SOR HELPER"
        .Cells(1, 6).Value = "SOR"
        .Cells(1, 7).Value = "IS GREATER THAN 0"
        .Cells(1, 8).Value = "Stock Code"
        .Cells(1, 9).Value = "Qty on Order"
        .Cells(1, 10).Value = "QTY Picked"
        .Cells(1, 11).Value = "QTY Needed"
        .Cells(1, 12).Value = "QTY on POR"
        .Cells(1, 13).Value = "US CODE"
        .Cells(1, 14).Value = "Location"
        .Cells(1, 15).Value = "Order Date"
        .Cells(1, 16).Value = "Availability Date"
        .Cells(1, 17).Value = "Del Request"
        .Cells(1, 18).Value = "ODM Promise"
        .Cells(1, 19).Value = "LOAD NEXT CONTAINER"
        .Cells(1, 20).Value = "Del Promise"
        .Cells(1, 21).Value = "Category"
                          
        i = 2
        For Each key In dict
            For j = 1 To dict(key)(0)
                .Cells(i, 1).Value = key
                .Cells(i, 2).Value = key
                .Cells(i, 3).Value = key
                .Cells(i, 4).Value = key
                .Cells(i, 5).Value = key
                .Cells(i, 6).Value = key
                .Cells(i, 7).Value = key
                .Cells(i, 8).Value = key
                .Cells(i, 9).Value = 1
                .Cells(i, 11).Value = key
                .Cells(i, 12).Value = key
                .Cells(i, 13).Value = key
                .Cells(i, 14).Value = key
                .Cells(i, 15).Value = key
                .Cells(i, 16).Value = key
                .Cells(i, 17).Value = key
                .Cells(i, 18).Value = key
                .Cells(i, 19).Value = key
                .Cells(i, 20).Value = key
                .Cells(i, 21).Value = key
                
                If j <= dict(key)(1) Then
                    .Cells(i, 10).Value = 1
                Else
                    .Cells(i, 10).Value = 0
                End If
                i = i + 1
            Next j
        Next key
    End With


End Sub

Warcupine · Answer 1 · 2022-05-24T15:05:03.493

This uses a dictionary and creates a new sheet to contain your expanded data.

    Dim i As Long
    Dim lr As Long
    Dim dict As Object
    Dim temparr As Variant 'For duplicates
    Dim newsheet As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet1") 'Change as needed
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            If Not dict.exists(.Cells(i, 1).Value) Then
                dict.Add .Cells(i, 1).Value, Array(.Cells(i, 2).Value, .Cells(i, 3).Value)
            Else
                'Not sure what to do about dupes, adding quantities together
                temparr = dict(.Cells(i, 1).Value)
                temparr(0) = dict(.Cells(i, 1).Value)(0) + .Cells(i, 2).Value
                temparr(1) = dict(.Cells(i, 1).Value)(1) + .Cells(i, 3).Value
                dict(.Cells(i, 1).Value) = temparr
            End If
        Next i
    End With
    
    Set newsheet = ThisWorkbook.Sheets.Add
    
    With newsheet
        Dim key As Variant
        Dim j As Long
        .Cells(1, 1).Value = "Product"
        .Cells(1, 2).Value = "Quantity"
        .Cells(1, 3).Value = "Picked"
        i = 2
        For Each key In dict
            For j = 1 To dict(key)(0)
                .Cells(i, 1).Value = key
                .Cells(i, 2).Value = 1
                If j <= dict(key)(1) Then
                    .Cells(i, 3).Value = 1
                Else
                    .Cells(i, 3).Value = 0
                End If
                i = i + 1
            Next j
        Next key
    End With

Updated with new Info:

With that many columns an array gets a bit unwieldy. I've loaded the data into a class, this complicates implementation but makes it easier to understand what is going on.

The Class Module:

Option Explicit

Private Type ProdData
    'I'm assuming these are all strings, change as needed
    ModelH As String
    DealerH As String
    Account As String
    Dealer As String
    SorH As String
    Sor As String
    Category As String
    Stock As String
    USCode As String
    Location As String
    
    Positive As Boolean
    LoadCont As Boolean

    
    'If you need decimals change from Long to Double
    OrderQty As Long
    PickQty As Long
    NeededQty As Long
    PorQty As Long
    
    OrderDate As Date
    AvailDate As Date
    ReqDate As Date
    PromiseDate As Date
    DelDate As Date
    
End Type

Private data As ProdData

Public Sub load_data(sheet As Worksheet, i As Long)
    With sheet
        data.ModelH = .Cells(i, 1).Value
        data.DealerH = .Cells(i, 2).Value
        data.Account = .Cells(i, 3).Value
        data.Dealer = .Cells(i, 4).Value
        data.SorH = .Cells(i, 5).Value
        data.Sor = .Cells(i, 6).Value
        data.Positive = .Cells(i, 7).Value
        data.Stock = .Cells(i, 8).Value
        data.OrderQty = .Cells(i, 9).Value
        data.PickQty = .Cells(i, 10).Value
        data.NeededQty = .Cells(i, 11).Value
        data.PorQty = .Cells(i, 12).Value
        data.USCode = .Cells(i, 13).Value
        data.Location = .Cells(i, 14).Value
        data.OrderDate = .Cells(i, 15).Value
        data.AvailDate = .Cells(i, 16).Value
        data.ReqDate = .Cells(i, 17).Value
        data.PromiseDate = .Cells(i, 18).Value
        data.LoadCont = .Cells(i, 19).Value
        data.PromiseDate = .Cells(i, 20).Value
        data.Category = .Cells(i, 21).Value
    End With
End Sub

Public Sub add_data(sheet As Worksheet, oldvals As data)
    With sheet
        data.OrderQty = oldvals.OrderQty + data.OrderQty
        data.PickQty = oldvals.PickQty + data.PickQty
        data.NeededQty = oldvals.NeededQty + data.NeededQty
        data.PorQty = oldvals.PorQty + data.PorQty
    End With
End Sub

Public Sub write_data(sheet As Worksheet, i As Long, j As Long)
    With sheet
        .Cells(i, 1).Value = data.ModelH
        .Cells(i, 2).Value = data.DealerH
        .Cells(i, 3).Value = data.Account
        .Cells(i, 4).Value = data.Dealer
        .Cells(i, 5).Value = data.SorH
        .Cells(i, 6).Value = data.Sor
        .Cells(i, 7).Value = data.Positive
        .Cells(i, 8).Value = data.Stock
        .Cells(i, 9).Value = 1
        .Cells(i, 11).Value = data.NeededQty
        .Cells(i, 12).Value = data.PorQty
        .Cells(i, 13).Value = data.USCode
        .Cells(i, 14).Value = data.Location
        .Cells(i, 15).Value = data.OrderDate
        .Cells(i, 16).Value = data.AvailDate
        .Cells(i, 17).Value = data.ReqDate
        .Cells(i, 18).Value = data.PromiseDate
        .Cells(i, 19).Value = data.LoadCont
        .Cells(i, 20).Value = data.DelDate
        .Cells(i, 21).Value = data.Category
        
        If j <= data.PickQty Then
            .Cells(i, 10).Value = 1
        Else
            .Cells(i, 10).Value = 0
        End If
    End With
End Sub

Public Property Get Stock() As String
    Stock = data.Stock
End Property

Public Property Get OrderQty() As Long
    OrderQty = data.OrderQty
End Property

Public Property Get PickQty() As Long
    PickQty = data.PickQty
End Property

Public Property Get NeededQty() As Long
    NeededQty = data.NeededQty
End Property

Public Property Get PorQty() As Long
    PorQty = data.PorQty
End Property

You will need to place this into a Class Module, I've named mine Data.

The Code Module:

Option Explicit

Sub TestMacro()

Dim i As Long
    Dim lr As Long
    Dim dict As Object
    Dim newsheet As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    Dim data As data 'User Defined Class
    
    With Sheets("ExchequerReport") 'Change as needed
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            Set data = New data
            data.load_data Sheets("ExchequerReport"), i
            
            If Not dict.exists(data.Stock) Then
                dict.Add data.Stock, data
            Else
                'Not sure what to do about dupes, adding quantities together
                data.add_data Sheets("ExchequerReport"), dict(data.Stock)
                Set dict(data.Stock) = data
            End If
        Next i
    End With
    
    Set newsheet = ThisWorkbook.Sheets.Add
    
    With newsheet
        Dim key As Variant
        Dim j As Long
        .Cells(1, 1).Value = "Model Helper"
        .Cells(1, 2).Value = "Dealer Helper"
        .Cells(1, 3).Value = "Account Code"
        .Cells(1, 4).Value = "Dealer"
        .Cells(1, 5).Value = "SOR HELPER"
        .Cells(1, 6).Value = "SOR"
        .Cells(1, 7).Value = "IS GREATER THAN 0"
        .Cells(1, 8).Value = "Stock Code"
        .Cells(1, 9).Value = "Qty on Order"
        .Cells(1, 10).Value = "QTY Picked"
        .Cells(1, 11).Value = "QTY Needed"
        .Cells(1, 12).Value = "QTY on POR"
        .Cells(1, 13).Value = "US CODE"
        .Cells(1, 14).Value = "Location"
        .Cells(1, 15).Value = "Order Date"
        .Cells(1, 16).Value = "Availability Date"
        .Cells(1, 17).Value = "Del Request"
        .Cells(1, 18).Value = "ODM Promise"
        .Cells(1, 19).Value = "LOAD NEXT CONTAINER"
        .Cells(1, 20).Value = "Del Promise"
        .Cells(1, 21).Value = "Category"
                          
        i = 2
        For Each key In dict
            For j = 1 To dict(key).OrderQty
                dict(key).write_data newsheet, i, j
                i = i + 1
            Next j
        Next key
    End With

End Sub

Thank you for this, I've tried to adapt it up in the original post for the actual data set it's applying to, which has more fields but I think I must have mistypes or misinterpreted parts of the code as it doesnt work for me. What have i missed? thanks — Joe, May 24 '22 at 13:32
thank you, this goes above and beyond. I've created a class module called Data too I am getting "Run-time error '13' type mismatch — Joe, May 24 '22 at 15:40
What line causes that, it is probably one of the types in the userdefined type, I just guessed what most of them were. — Warcupine, May 24 '22 at 15:46

VBA - Split row by quantity by values

1 Answers1