Working with variant array

[mehidy1437]

Hello dear,

I have data in a2:f5, a1:f1 is header row.
a2:c5 contain the details like style, order & color
d2:f5 contain the quantity. I would like to perform the calculation on d2:f5.
d2:f5 each cell will divided by 30, like 100/30=3.333
so for d2 it will be 100/30=3.3333, in d2 cell value will be 30 & i will put 3 in g2
balance value 100-(30*3) = 10, will put on d3 & i will put 1 in g3 for this.
like this it will go on for others cell.

I want to do this using variant array, i want to load the data a2:f5 in array > do the calculation & then insert the output in the sheet.

See below raw data, & required output.

Please help me to do this.

Raw data

pkl v04.xlsm
	A	B	C	D	E	F
1	STYLE	ORDER	COLOR	S	M	L
2	XXX	200	300	100	100	90
3	XXX	200	400	100	60	100
4	XXX	300	300	100	100	120
5	YYY	300	400	100	140	100
Sheet1 (30)

Desired output

pkl v04.xlsm
	A	B	C	D	E	F	G
1	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	30			3
3	XXX	200	300	10			1
4	XXX	200	300		30		3
5	XXX	200	300		10		1
6	XXX	200	300			30	3
7	XXX	200	400	30			3
8	XXX	200	400	10			1
9	XXX	200	400		30		2
10	XXX	200	400			30	3
11	XXX	200	400			10	1
12	XXX	300	300	30			3
13	XXX	300	300	10			1
14	XXX	300	300		30		3
15	XXX	300	300		10		1
16	XXX	300	300			30	4
17	YYY	300	400	30			3
18	YYY	300	400	10			1
19	YYY	300	400		30		4
20	YYY	300	400		20		1
21	YYY	300	400			30	3
22	YYY	300	400			10	1
Sheet1 (34)

 

[kevin9999]

Try the following on a copy of your workbook. This demonstration takes the values on "Sheet1" and puts them (once calculated) onto "Sheet2". Change the sheet names to suit.

Option Explicit
Sub mehidy1437()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<~~ *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Dim ArrIn, ArrOut
    Dim x As Long
    x = WorksheetFunction.CountIf(ws1.Range("D2", ws1.Cells(Rows.Count, "F").End(xlUp)), ">0") * 2
    
    ArrIn = ws1.Range("A2", ws1.Cells(Rows.Count, "F").End(xlUp))
    ReDim ArrOut(1 To x, 1 To 7)
    Dim i As Long, j As Long, k As Long, m As Long
    j = 1: m = 4
    For i = 1 To UBound(ArrIn, 1)
        For m = 4 To 6
            If ArrIn(i, m) > 30 Then
            For k = 1 To 3
                ArrOut(j, k) = ArrIn(i, k)
            Next k
            ArrOut(j, m) = 30
            ArrOut(j, 7) = Int(ArrIn(i, m) / 30)
            If ArrIn(i, m) Mod 30 > 0 Then
                j = j + 1
                For k = 1 To 3
                    ArrOut(j, k) = ArrIn(i, k)
                Next k
                ArrOut(j, 7) = 1
                ArrOut(j, m) = ArrIn(i, m) Mod 30
            End If
            j = j + 1
            End If
        Next m
        m = 4
    Next i
    
    With ws2
        .Cells(1, 1).Resize(1, 7).Value = Array("STYLE", "ORDER", "COLOR", "S", "M", "L", "CTN")
        .Cells(2, 1).Resize(UBound(ArrOut, 1), 7).Value = ArrOut
        .Range("A:G").HorizontalAlignment = xlCenter
    End With
    
    Dim LRow As Long, a As String, b As String, c As String
    LRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To LRow
        ws1.Cells(i, 1).Resize(1, 6).Copy
        a = ws1.Cells(i, 1): b = ws1.Cells(i, 2): c = ws1.Cells(i, 3)
        For j = 2 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
            If ws2.Cells(j, 1) = a And ws2.Cells(j, 2) = b And ws2.Cells(j, 3) = c Then
                ws2.Cells(j, 1).Resize(1, 6).PasteSpecial xlPasteFormats
            End If
        Next j
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Starting with this layout on "Sheet1"

mehidy1437.xlsm
	A	B	C	D	E	F
1	STYLE	ORDER	COLOR	S	M	L
2	XXX	200	300	100	100	90
3	XXX	200	400	100	60	100
4	XXX	300	300	100	100	120
5	YYY	300	400	100	140	100
6
Sheet1

It produces this on "Sheet2":

mehidy1437.xlsm
	A	B	C	D	E	F	G
1	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	30			3
3	XXX	200	300	10			1
4	XXX	200	300		30		3
5	XXX	200	300		10		1
6	XXX	200	300			30	3
7	XXX	200	400	30			3
8	XXX	200	400	10			1
9	XXX	200	400		30		2
10	XXX	200	400			30	3
11	XXX	200	400			10	1
12	XXX	300	300	30			3
13	XXX	300	300	10			1
14	XXX	300	300		30		3
15	XXX	300	300		10		1
16	XXX	300	300			30	4
17	YYY	300	400	30			3
18	YYY	300	400	10			1
19	YYY	300	400		30		4
20	YYY	300	400		20		1
21	YYY	300	400			30	3
22	YYY	300	400			10	1
23
Sheet2

 

[JamesCanale]

365 way.

MrExcelPlayground18.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	STYLE	ORDER	COLOR	S	M	L	30	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	90	100	90		XXX	200	300	30	0	0	3
3	XXX	200	400	100	60	100		XXX	200	300	0	30	0	3
4	XXX	300	300	100	100	120		XXX	200	300	0	10	0	1
5	YYY	300	400	100	140	100		XXX	200	300	0	0	30	3
6								XXX	200	400	30	0	0	3
7								XXX	200	400	10	0	0	1
8								XXX	200	400	0	30	0	2
9								XXX	200	400	0	0	30	3
10								XXX	200	400	0	0	10	1
11								XXX	300	300	30	0	0	3
12								XXX	300	300	10	0	0	1
13								XXX	300	300	0	30	0	3
14								XXX	300	300	0	10	0	1
15								XXX	300	300	0	0	30	4
16								YYY	300	400	30	0	0	3
17								YYY	300	400	10	0	0	1
18								YYY	300	400	0	30	0	4
19								YYY	300	400	0	20	0	1
20								YYY	300	400	0	0	30	3
21								YYY	300	400	0	0	10	1
Sheet11

Cell Formulas
Range	Formula
H2:N21	H2	=LET(x,G1,y,A2:C5,z,D2:F5, a,INT(z/x), b,MOD(z,x), d,1+INT(SEQUENCE(ROWS(a)*6,1,0,1/6)), dd,MOD(SEQUENCE(ROWS(a)*6,1,0),6)+1, ddd,INT((dd-1)/2)+1, e,INDEX(y,d,{1,2,3}), f,IF(ISODD(dd),INDEX(a,d,ddd),INDEX(b,d,ddd)), ff,IF(ISODD(dd),IF(f>0,f,0),IF(f>0,1,0)), g,MOD(SEQUENCE(ROWS(a)*6,3,0),3)+1, h,IF(ddd=g,IF(ISODD(dd),IF(f>0,x,0),f),0), v,HSTACK(e,h,ff), FILTER(v,TAKE(v,,-1)>0))
Dynamic array formulas.

 

[mehidy1437]

@kevin9999 thanks a lot for your help.

2nd step:
Now, can we add some more condition into it like,
if in range d2:f22 any cell value is less than 30, then it will move the value to last row, if last row value is less than 30.
Otherwise, If last row cell value is 30, then it will insert a new row & copy down the value to the new row.

pkl v04.xlsm
	A	B	C	D	E	F	G	H
1	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	30			3
3	XXX	200	300				1	delete this row
4	XXX	200	300		30		3
5	XXX	200	300				1
6	XXX	200	300			30	3
7	XXX	200	300	10	10		1	add new row
8	XXX	200	400	30			3
9	XXX	200	400				1	delete this row
10	XXX	200	400		30		2
11	XXX	200	400			30	3
12	XXX	200	400	10		10	1	add value to last row
13	XXX	300	300	30			3
14	XXX	300	300				1	delete this row
15	XXX	300	300		30		3
16	XXX	300	300				1
17	XXX	300	300			30	4
18	XXX	300	300	10	10		4	add new row
19	YYY	300	400	30			3
20	YYY	300	400				1	delete this row
21	YYY	300	400		30		4
22	YYY	300	400				1	delete this row
23	YYY	300	400			30	3
24	YYY	300	400	10	20	10	1	add value to last row
Sheet6

3rd step:
Final step is, to sum up the value of the last row cells till it become 30.
Considering cell d18, e18, f18 value is like 10, 25 & 10
So it will sum up first two cell 10+20=30, balance value of e18 is 5 will insert below new row e19 & f18 value will be put in f19
This can happen for multiple row in the range.

pkl v04.xlsm
	A	B	C	D	E	F	G	H
1	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	30			3
3	XXX	200	300		30		3
4	XXX	200	300				1
5	XXX	200	300			30	3
6	XXX	200	300	10	10		1
7	XXX	200	400	30			3
8	XXX	200	400		30		2
9	XXX	200	400			30	3
10	XXX	200	400	10		10	1
11	XXX	300	300	30			3
12	XXX	300	300		30		3
13	XXX	300	300			30	4
14	XXX	300	300	10	10		4
15	YYY	300	400	30			3
16	YYY	300	400		30		4
17	YYY	300	400			30	3
18	YYY	300	400	10	20		1	consider e18 value is 25 & f18 is 10
19	YYY	300	400		5	10	1	balance value insert to new row
Sheet6 (2)

 

[mehidy1437]

@JamesCanale thanks for your input, i have to study it.

 

[kevin9999]

Before I look at this again, I need to know that you're not going to continually add "next steps" to this project every time you get a solution. You should list all of your requirements at the start, and not keep adding them as you go along.

 

[mehidy1437]

@kevin9999 no, this is my final output.
No need to add any more step into this.

thank again for your response.

 

[kevin9999]

Try the following on a copy of your workbook. Again, just change the sheet names to suit.

Option Explicit
Sub mehidy1437_V2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<~~ *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Dim ArrIn, ArrOut
    Dim x As Long
    x = WorksheetFunction.CountIf(ws1.Range("D2", ws1.Cells(Rows.Count, "F").End(xlUp)), ">0") * 2
    
    ArrIn = ws1.Range("A2", ws1.Cells(Rows.Count, "F").End(xlUp))
    ReDim ArrOut(1 To x, 1 To 7)
    Dim i As Long, j As Long, k As Long, m As Long
    j = 1: m = 4
    For i = 1 To UBound(ArrIn, 1)
        For m = 4 To 6
            If ArrIn(i, m) > 30 Then
            For k = 1 To 3
                ArrOut(j, k) = ArrIn(i, k)
            Next k
            ArrOut(j, m) = 30
            ArrOut(j, 7) = Int(ArrIn(i, m) / 30)
            If ArrIn(i, m) Mod 30 > 0 Then
                j = j + 1
                For k = 1 To 3
                    ArrOut(j, k) = ArrIn(i, k)
                Next k
                ArrOut(j, 7) = 1
                ArrOut(j, m) = ArrIn(i, m) Mod 30
            End If
            j = j + 1
            End If
        Next m
        m = 4
    Next i
    
    With ws2
        .Cells(1, 1).Resize(1, 7).Value = Array("STYLE", "ORDER", "COLOR", "S", "M", "L", "CTN")
        .Cells(2, 1).Resize(UBound(ArrOut, 1), 7).Value = ArrOut
        .Range("A:G").HorizontalAlignment = xlCenter
        Dim LRow As Long, XRow As Long, a As String, b As String, c As String, r As Range
        LRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        
        For i = LRow To 2 Step -1
            If .Cells(i, 1) <> .Cells(i + 1, 1) Or .Cells(i, 2) <> .Cells(i + 1, 2) Or .Cells(i, 3) <> .Cells(i + 1, 3) Then
                If Application.Max(.Cells(i, 4).Resize(1, 3)) = 30 Then
                    .Cells(i, 1).Offset(1).EntireRow.Insert
                    .Cells(i, 1).Resize(1, 3).Copy .Cells(i, 1).Offset(1)
                End If
            End If
        Next i
        
        LRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        For i = 2 To LRow
            If .Cells(i, 1) <> .Cells(i + 1, 1) Or .Cells(i, 2) <> .Cells(i + 1, 2) Or .Cells(i, 3) <> .Cells(i + 1, 3) Then
                j = i
                If .Cells(j, 4) = "" Then XRow = .Cells(j, 4).End(xlUp).Row: .Cells(j, 4) = .Cells(XRow, 4): If .Cells(XRow, 4) <> 30 Then .Cells(XRow, 4) = ""
                If .Cells(j, 5) = "" Then XRow = .Cells(j, 5).End(xlUp).Row: .Cells(j, 5) = .Cells(XRow, 5): If .Cells(XRow, 5) <> 30 Then .Cells(XRow, 5) = ""
                If .Cells(j, 6) = "" Then XRow = .Cells(j, 6).End(xlUp).Row: .Cells(j, 6) = .Cells(XRow, 6): If .Cells(XRow, 6) <> 30 Then .Cells(XRow, 6) = ""
                .Cells(j, 7) = 1
                For Each r In .Range(.Cells(j, 4), .Cells(j, 6))
                    If r = 30 Then r = ""
                Next r
            End If
        Next i
        
        With .Range("A1").CurrentRegion
            .AutoFilter 4, "="
            .AutoFilter 5, "="
            .AutoFilter 6, "="
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        
        For i = 2 To LRow
            If .Cells(i, 1) <> .Cells(i + 1, 1) Or .Cells(i, 2) <> .Cells(i + 1, 2) Or .Cells(i, 3) <> .Cells(i + 1, 3) Then
                j = i
                If Application.Sum(.Range(.Cells(j, 4), .Cells(j, 6))) > 30 Then
                    .Cells(i, 1).Offset(1).EntireRow.Insert
                    .Cells(i, 1).Resize(1, 3).Copy .Cells(i, 1).Offset(1)
                    .Cells(j + 1, 7) = 1
                    If (.Cells(j, 4)) > 0 Then x = 30 - .Cells(j, 4)
                    If (.Cells(j, 5)) > x Then
                        .Cells(j + 1, 5) = .Cells(j, 5) - x
                        .Cells(j, 5) = x
                    End If
                    If Application.Sum(.Range(.Cells(j, 4), .Cells(j, 6))) > 30 Then
                        .Cells(j + 1, 6) = .Cells(j, 6)
                        .Cells(j, 6) = ""
                    End If
                End If
            End If
        Next i
    End With
    
    LRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To LRow
        ws1.Cells(i, 1).Resize(1, 6).Copy
        a = ws1.Cells(i, 1): b = ws1.Cells(i, 2): c = ws1.Cells(i, 3)
        For j = 2 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
            If ws2.Cells(j, 1) = a And ws2.Cells(j, 2) = b And ws2.Cells(j, 3) = c Then
                ws2.Cells(j, 1).Resize(1, 6).PasteSpecial xlPasteFormats
            End If
        Next j
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

From this:

mehidy1437.xlsm
	A	B	C	D	E	F
1	STYLE	ORDER	COLOR	S	M	L
2	XXX	200	300	140	140	100
3	XXX	200	400	100	60	100
4	XXX	300	300	100	100	120
5	YYY	300	400	100	145	100
6
Sheet1

This is produced:

mehidy1437.xlsm
	A	B	C	D	E	F	G
1	STYLE	ORDER	COLOR	S	M	L	CTN
2	XXX	200	300	30			4
3	XXX	200	300		30		4
4	XXX	200	300			30	3
5	XXX	200	300	20	10		1
6	XXX	200	300		10	10	1
7	XXX	200	400	30			3
8	XXX	200	400		30		2
9	XXX	200	400			30	3
10	XXX	200	400	10		10	1
11	XXX	300	300	30			3
12	XXX	300	300		30		3
13	XXX	300	300			30	4
14	XXX	300	300	10	10		1
15	YYY	300	400	30			3
16	YYY	300	400		30		4
17	YYY	300	400			30	3
18	YYY	300	400	10	20		1
19	YYY	300	400		5	10	1
Sheet2

 

[mehidy1437]

@kevin9999 millions of thanks my dear.
I'm so grateful for your help with the project.
I really appreciate your willingness to help out.
You are great.

 

[kevin9999]

@kevin9999 millions of thanks my dear.
I'm so grateful for your help with the project.
I really appreciate your willingness to help out.
You are great.

Happy to help and thanks for the feedback