VBA to insert a duplicate row based on criteria

[Chaozfate]

Hi,

I wonder if this could be solve by VBA, would be very much appreciate if anyone could help to write a VBA for me if the request is even posssible.

First I have a Sheet 1 as following:

Number	Additional	Dividend
A0001	0	500
B0002	100	600

I would like the VBA to detect if there the value on Additional column is more than 0, it will generate a report on Sheet 2 as following:

Number	Particular	Amount
A0001	Dividend	500
B0002	Dividend	600
B0002	Additional	100

Really hope something can help to resolve this cause i am dealing with 2000 lines or more on Sheet 1.

Thanks!

 

[EXCEL MAX]

Hello Chaozfate,
I don't know details of the request, but think this code shuld be helpful.

Option Explicit

Sub NewReport()

    Dim varWS As Worksheet, varWS2 As Worksheet
    Dim varNRows As Long, varNRows2 As Long
    Dim varRange1 As Range, varRange2 As Range
   
    Application.ScreenUpdating = False
    Set varWS = Worksheets("Sheet1")
    Set varWS2 = Worksheets("Sheet2")
    varNRows = varWS.UsedRange.Rows.Count
    Set varRange2 = varWS.Range("B2:B" & varNRows)
    varWS2.Range("A1") = "Number"
    varWS2.Range("B1") = "Particular"
    varWS2.Range("C1") = "Amount"
    
    For Each varRange1 In varRange2
        varNRows2 = varWS2.UsedRange.Rows.Count + 2
        If varRange1.Value > 0 Then
           varWS2.Range("A" & varNRows2 - 1) = varRange1.Offset(-1, -1).Value
           varWS2.Range("B" & varNRows2 - 1) = "Dividend"
           varWS2.Range("C" & varNRows2 - 1) = varRange1.Offset(-1, 1).Value
           varWS2.Range("A" & varNRows2) = varRange1.Offset(0, -1).Value
           varWS2.Range("B" & varNRows2) = "Dividend"
           varWS2.Range("C" & varNRows2) = varRange1.Offset(0, 1).Value
           varWS2.Range("A" & varNRows2 + 1) = varRange1.Offset(0, -1).Value
           varWS2.Range("B" & varNRows2 + 1) = "Additional"
           varWS2.Range("C" & varNRows2 + 1) = varRange1.Value
        End If
    Next
    Application.ScreenUpdating = True
    
End Sub

 

[GWteB]

The code below might be another solution. Paste it in a separate module (note the line with Option Base 1)

Option Explicit
Option Base 1       ' <<<  Be sure to have this line on top of the code module

Public Sub Chaozfate()

    Dim rng     As Range
    Dim arrSrc  As Variant
    Dim arrDest As Variant
    Dim j       As Long
    Dim n       As Long

    With ThisWorkbook.Sheets("Sheet1")
        Set rng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Resize(, 3)
    End With
    
    arrSrc = Application.Transpose(rng)
    ReDim arrDest(UBound(arrSrc), 1)
    For j = LBound(arrSrc, 2) To UBound(arrSrc, 2)
        n = n + 1
        ReDim Preserve arrDest(UBound(arrSrc), n)
        arrDest(1, n) = arrSrc(1, j)
        arrDest(2, n) = "Dividend"
        arrDest(3, n) = arrSrc(3, j)
        If arrSrc(2, j) > 0 Then
            n = n + 1
            ReDim Preserve arrDest(UBound(arrSrc), n)
            arrDest(1, n) = arrSrc(1, j)
            arrDest(2, n) = "Additional"
            arrDest(3, n) = arrSrc(2, j)
        End If
    Next j
    arrDest = Application.Transpose(arrDest)

    With ThisWorkbook.Sheets("Sheet2")
        Set rng = .Range("A2").Resize(UBound(arrDest), UBound(arrDest, 2))
    End With
    rng = arrDest

End Sub

 

[Chaozfate]

Thanks guys, this VBA is beyond my understanding but it works perfectly.

Both VBA function the same, with the difference of code from GWteB overwriting the previous generated result. This save me from creating another clearing code for the previous result.

Appreciate the time from both of you to draft the code, these code definitely helps with my 2000 lines.

Thanks again!

 

[alansidman]

An alternative solution is to employ Power Query

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Number"}, "Attribute", "Value"),
    #"Filtered Rows" = Table.SelectRows(#"Unpivoted Other Columns", each ([Value] <> 0))
in
    #"Filtered Rows"

Book5
	A	B	C	D	E	F	G
1	Number	Additional	Dividend		Number	Attribute	Value
2	A0001	0	500		A0001	Dividend	500
3	B0002	100	600		B0002	Additional	100
4					B0002	Dividend	600
Sheet1

 

[Chaozfate]

An alternative solution is to employ Power Query

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Number"}, "Attribute", "Value"),
    #"Filtered Rows" = Table.SelectRows(#"Unpivoted Other Columns", each ([Value] <> 0))
in
    #"Filtered Rows"

Book5
	A	B	C	D	E	F	G
1	Number	Additional	Dividend		Number	Attribute	Value
2	A0001	0	500		A0001	Dividend	500
3	B0002	100	600		B0002	Additional	100
4					B0002	Dividend	600
Sheet1

Thanks Alan, unfortunately, this is for office works and we cant install any add on without the IT permission.

Appreciate your respond.

 

[EXCEL MAX]

GWteB,
excellent advanced VBA technique.

 

[GWteB]

Thanks guys, this VBA is beyond my understanding but it works perfectly.
Both VBA function the same, with the difference of code from GWteB overwriting the previous generated result. This save me from creating another clearing code for the previous result.
Appreciate the time from both of you to draft the code, these code definitely helps with my 2000 lines.
Thanks again!

Glad we could help and thanks for letting us know.

GWteB,
excellent advanced VBA technique.

Thanks. In this case, using this technique is unlikely to cause any problems and typically performs faster than copying individual worksheet ranges.
However, an important side note must be made here. The outcome should never exceed 65,536 rows because that's the amount of rows the used Transpose function can handle without unusual results. With a greater number of rows the returned arrays will be truncated without any warning or run-time error (at least in Excel 2013).

 

[alansidman]

@Chaozfate
What version of Excel are you running. Power Query is part of 2016, 2019 and 365. It is not an addin for those versions. It is called Get and Transform in those versions and found on the Data Tab

 

[Chaozfate]

I see, my bad.

I am never exposed to power query, did some google and found out it was add on to excel and thought it was accordingly.

Thanks for your feedback, I try do some study into it see what it can offer.