VBA Help - Transform database by adding rows when conditions are met

[Yayo]

Hello Everyone, hope you're doing well!

First of all, this forum has been a great help as a resource to solve different excel issues and questions that I always have. As a lurker, I wanted to thank you all for the content and willingness to help!

As for my current problem/question, I wanted to make a macro that grabs and transforms some data from a database if certain conditions are met using VBA. Sadly, I haven't been able to achieve this! Hope you can help me!

Here's an example of what my database looks like and what the ideal result would be

Base Example

Data Base Transform - Example.xlsx
	A	B	C	D	E	F
3	C1	C2	C3	C4	C5	C6
4	Name1	X1X	A123	Prod1	1000	0
5	Name2	X2X	B123	Prod2	1200	0
6	Name3	X3X	C123	Prod3	1300	200
7	Name4	X4X	D123	Prod1	1000	200
8	Name4	X4X	D123	Prod4	1500	200
9	Name4	X4X	D123	Prod3	1300	200
10	Name5	X5X	E123	Prod1	1000	0
11	Name6	X6X	F123	Prod1	1000	0
12	Name7	X7X	G123	Prod9	800	200
13	Name7	X7X	G123	Prod10	900	200
14	Name8	X8X	H123	Prod7	1050	200
DB

Desired Result Example

Data Base Transform - Example.xlsx
	A	B	C	D	E	F
3	C1	C3	NewC7	C2	C4	NewC8
4	Name1	A123	E	X1X
5			B		Prod1	1000
6	Name2	B123	E	X2X
7			B		Prod2	1200
8	Name3	C123	E	X3X
9			B		Prod3	1300
10			B		C6Prod	200
11	Nam4	D123	E	X4X
12			B		Prod1	1000
13			B		Prod4	1500
14			B		Prod3	1300
15			B		C6Prod	600
16	Name5	E123	E	X5X
17			B		Prod1	1000
18	Name6	F123	E	X6X
19			B		Prod1	1000
20	Name7	G123	E	X7X
21			B		Prod9	800
22			B		Prod10	900
23			B		C6Prod	400
24	Name8	H123	E	X8X
25			B		Prod7	1050
26			B		C6Prod	200
Result

As for the conditions, here's the list of them
-> Every line will be transformed in at least 2 rows. The first one will always have a value of E (NEW C7) and data from C1, C2 and C3. The next rows will always have a value of B (NEW C7)
-> What determines the number of rows are the number of items from C4 (one for each ProdX) and if C6 contains any value (>0), the resulting item name will always be C6Prod
-> NewC8 will consolidate the values of C5 for each C4 ProdName and, in case there's a C6 value, the added sum of C6 column should be the value of C6Prod

The base will always be the same size and will have the same order, so I wanted a button that transform the DB and gives the shown result in a different sheet

Don't actually care about format, added it just for visual aid!

Thanks for your help and please let me know if something's missing

Cheers, Yayo

 

[Mario_R]

Hello.
This macro will create the 'Result' sheet if it doesn't exist:

Sub Macro8()
Dim a, Q&, i&, b, R&, C6Prod#, iKey$, ws As Worksheet
Application.ScreenUpdating = False
'---------------->
With Sheets("DB")
  a = .Range("A3", .[f6].End(xlDown)).Offset(1): Q = UBound(a)
  ReDim b(1 To 3 * Q, 1 To 6): R = 1
  For i = 1 To 6
    b(R, i) = Array("C1", "C3", "NewC7", "C2", "C4", "NewC8")(i - 1)
  Next
End With
'---------------->
i = 1
Do While a(i, 1) <> ""
  iKey = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
  C6Prod = 0: R = 1 + R
  b(R, 1) = a(i, 1): b(R, 2) = a(i, 3): b(R, 3) = "E": b(R, 4) = a(i, 2)
  Do
    R = 1 + R
    b(R, 3) = "B": b(R, 5) = a(i, 4): b(R, 6) = a(i, 5): C6Prod = C6Prod + a(i, 6)
    i = 1 + i
    If iKey <> a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) Then
      If C6Prod <> 0 Then R = 1 + R: b(R, 3) = "B": b(R, 5) = "C6Prod": b(R, 6) = C6Prod
      Exit Do
    End If
  Loop
Loop
'---------------->
If IsError(Evaluate("Cell(""Row"", Result!A1)")) Then Worksheets.Add(, Sheets("DB")).Name = "Result"
With Worksheets("Result")
  .Rows.RowHeight = 22: .Cells.VerticalAlignment = xlCenter
  .Cells.Font.Size = 12: .[a3].CurrentRegion.Delete xlShiftUp
  .[a3].Resize(R, 6) = b
  With .[a3].CurrentRegion
    .Rows(1).Font.Bold = True: .Columns("a:e").NumberFormat = "_ @_ "
    .Columns(6).NumberFormat = "_ #,##0.00_ ": .Columns.AutoFit
  End With
End With
End Sub

 

[kevin9999]

Similar approach to @Mario_R , which I'd already started so I thought I might finish it. Assumes you have both a DB and Result sheet, and that the data starts in row 4, and that your headers already exist in row 3 of the Result sheet.

Option Explicit
Sub Yayo()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("DB")
    Set ws2 = Worksheets("Result")
    Dim LRow As Long, LCol As Long, r As Range
    LRow = ws1.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    Set r = ws1.Range(ws1.Cells(4, 1), ws1.Cells(LRow, LCol))
    
    Dim a, b, c, i As Long, j As Long, k As Long, m As Long
    Dim x As Long, z As Long
    a = r
    ReDim b(1 To UBound(a, 1) * 3, 1 To 6)
    c = WorksheetFunction.Unique(r.Columns(1))
    
    k = 1: m = 1
    For i = 1 To UBound(c)
        x = 1 + WorksheetFunction.CountIf(r.Columns(1), c(i, 1))
        For j = 1 To x
            If j = 1 Then
                b(k, 1) = a(m, 1): b(k, 2) = a(m, 3): b(k, 3) = "E": b(k, 4) = a(m, 2): b(k, 5) = "": b(k, 6) = ""
            Else
                b(k, 1) = "": b(k, 2) = "": b(k, 3) = "B": b(k, 4) = "": b(k, 5) = a(m, 4): b(k, 6) = a(m, 5)
                m = m + 1
            End If
            k = k + 1
        Next j
        If WorksheetFunction.SumIf(r.Columns(1), c(i, 1), r.Columns(6)) > 0 Then
            z = WorksheetFunction.SumIf(r.Columns(1), c(i, 1), r.Columns(6))
            b(k, 1) = "": b(k, 2) = "": b(k, 3) = "B": b(k, 4) = "": b(k, 5) = "C6Prod": b(k, 6) = z
            k = k + 1
        End If
    Next i
    
    ws2.Range("A4").Resize(UBound(b, 1), 6).Value = b
End Sub

Result sheet after code is run:

Yayo.xlsm
	A	B	C	D	E	F
3	C1	C3	NewC7	C2	C4	NewC8
4	Name1	A123	E	X1X
5			B		Prod1	1000
6	Name2	B123	E	X2X
7			B		Prod2	1200
8	Name3	C123	E	X3X
9			B		Prod3	1300
10			B		C6Prod	200
11	Name4	D123	E	X4X
12			B		Prod1	1000
13			B		Prod4	1500
14			B		Prod3	1300
15			B		C6Prod	600
16	Name5	E123	E	X5X
17			B		Prod1	1000
18	Name6	F123	E	X6X
19			B		Prod1	1000
20	Name7	G123	E	X7X
21			B		Prod9	800
22			B		Prod10	900
23			B		C6Prod	400
24	Name8	H123	E	X8X
25			B		Prod7	1050
26			B		C6Prod	200
Result

 

[Yayo]

@Mario_R @kevin9999

Thanks a lot for your help! you guys are awesome! Both of your solutions fit my needs and solved most of my problem! So again, thanks a lot for the help and time for creating this macro

I managed to change some things to adapt it to my database and finally it's doing what I needed with what you guys created

I'm just missing one last part which I forgot to mention in my main post!

I wanted to add 3 last columns which would be something like this (80% of the Total, 20% of the Total, Total(

Data Base Transform - Example.xlsx
	A	B	C	D	E	F	G	H	I
3	C1	C3	NewC7	C2	C4	NewC8	80%C9	20%C10	Total
4	Name1	A123	E	X1X			800	200	1000
5			B		Prod1	1000
6	Name2	B123	E	X2X			960	240	1200
7			B		Prod2	1200
8	Name3	C123	E	X3X			1200	300	1500
9			B		Prod3	1300
10			B		C6Prod	200
11	Nam4	D123	E	X4X			3520	880	4400
12			B		Prod1	1000
13			B		Prod4	1500
14			B		Prod3	1300
15			B		C6Prod	600
16	Name5	E123	E	X5X			800	200	1000
17			B		Prod1	1000
18	Name6	F123	E	X6X			800	200	1000
19			B		Prod1	1000
20	Name7	G123	E	X7X			1680	420	2100
21			B		Prod9	800
22			B		Prod10	900
23			B		C6Prod	400
24	Name8	H123	E	X8X			1000	250	1250
25			B		Prod7	1050
26			B		C6Prod	200
Result

Thanks again for all the help you've provided, it means a lot!

Kind regards,

 

[kevin9999]

Do those additional columns come from your source data, or do they need to be calculated?

 

[Yayo]

In this case, the Total column comes from the database. The total would be the sum of each prod.

Like the table shows, Name 1 has only Prod 1, so the total is 1000
Name 4 has Prod 1,3,4 and C6Prod, so the total is the added sum of every value from C5 and C6 of the DB (would be like SUM(E7:F9) from DB)

In case of the other columns, it's a calculation of the Total --> C9 = 80% of Total, C10 = 20% of Total

Hope it's clear!

 

[kevin9999]

the Total column comes from the database

Could you provide another XL2BB of the database that shows the Total column.

 

[Yayo]

Could you provide another XL2BB of the database that shows the Total column.

I'm sorry, now I understand what you meant by if it comes from the database

The total column doesn't come from it because the database changes constantly. Saying that, the ideal total column should be calculated as the conditions explained in the last post!

I'll try to explain myself better!

The Total column should add up all the values from C5 and C6, and should be on the E row for each Name. In case of C9 and C10, it's a calculated % of the total column

Is that a better explaination?

I'm sorry, my english is kinda limited when trying to explain in details these kind of things

Kind regards,

 

[kevin9999]

I'm sorry, now I understand what you meant by if it comes from the database

The total column doesn't come from it because the database changes constantly. Saying that, the ideal total column should be calculated as the conditions explained in the last post!

I'll try to explain myself better!

The Total column should add up all the values from C5 and C6, and should be on the E row for each Name. In case of C9 and C10, it's a calculated % of the total column

Is that a better explaination?

I'm sorry, my english is kinda limited when trying to explain in details these kind of things

Kind regards,

Understood, so it's calculated at run time. Leave it with me

 

[kevin9999]

Try the following on a copy of your data.

Option Explicit
Sub Yayo_V2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("DB")
    Set ws2 = Worksheets("Result")
    Dim LRow As Long, LCol As Long, r As Range
    LRow = ws1.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    Set r = ws1.Range(ws1.Cells(4, 1), ws1.Cells(LRow, LCol))
    
    With r
        .Offset(, LCol + 2).Resize(, 1).Formula2R1C1 = "=Sum(If(R4C1:R" & LRow & "C1=RC1,R4C5:R" & LRow & "C6))"
        .Offset(, LCol).Resize(, 1).Formula2R1C1 = "=RC[2]*.8"
        .Offset(, LCol + 1).Resize(, 1).Formula2R1C1 = "=RC[1]*.2"
        With r.Offset(, LCol).Resize(, 3)
            .Value = .Value
        End With
    End With
    
    Set r = ws1.Range(ws1.Cells(4, 1), ws1.Cells(LRow, LCol + 3))
    
    Dim a, b, c, i As Long, j As Long, k As Long, m As Long
    Dim x As Long, z As Long
    a = r
    ReDim b(1 To UBound(a, 1) * 3, 1 To 9)
    c = WorksheetFunction.Unique(r.Columns(1))
    
    k = 1: m = 1
    For i = 1 To UBound(c)
        x = 1 + WorksheetFunction.CountIf(r.Columns(1), c(i, 1))
        For j = 1 To x
            If j = 1 Then
                b(k, 1) = a(m, 1): b(k, 2) = a(m, 3): b(k, 3) = "E": b(k, 4) = a(m, 2): b(k, 5) = "": b(k, 6) = "": b(k, 7) = a(m, 7): b(k, 8) = a(m, 8): b(k, 9) = a(m, 9)
            Else
                b(k, 1) = "": b(k, 2) = "": b(k, 3) = "B": b(k, 4) = "": b(k, 5) = a(m, 4): b(k, 6) = a(m, 5)
                m = m + 1
            End If
            k = k + 1
        Next j
        If WorksheetFunction.SumIf(r.Columns(1), c(i, 1), r.Columns(6)) > 0 Then
            z = WorksheetFunction.SumIf(r.Columns(1), c(i, 1), r.Columns(6))
            b(k, 1) = "": b(k, 2) = "": b(k, 3) = "B": b(k, 4) = "": b(k, 5) = "C6Prod": b(k, 6) = z
            k = k + 1
        End If
    Next i
    
    ws2.Range("A4").Resize(UBound(b, 1), 9).Value = b
    r.Offset(, LCol).Resize(, 3).ClearContents
End Sub

After running the code:

Yayo.xlsm
	A	B	C	D	E	F	G	H	I
3	C1	C3	NewC7	C2	C4	NewC8	80%C9	20%C10	Total
4	Name1	A123	E	X1X			800	200	1000
5			B		Prod1	1000
6	Name2	B123	E	X2X			960	240	1200
7			B		Prod2	1200
8	Name3	C123	E	X3X			1200	300	1500
9			B		Prod3	1300
10			B		C6Prod	200
11	Name4	D123	E	X4X			3520	880	4400
12			B		Prod1	1000
13			B		Prod4	1500
14			B		Prod3	1300
15			B		C6Prod	600
16	Name5	E123	E	X5X			800	200	1000
17			B		Prod1	1000
18	Name6	F123	E	X6X			800	200	1000
19			B		Prod1	1000
20	Name7	G123	E	X7X			1680	420	2100
21			B		Prod9	800
22			B		Prod10	900
23			B		C6Prod	400
24	Name8	H123	E	X8X			1000	250	1250
25			B		Prod7	1050
26			B		C6Prod	200
Result