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!

 

[Chaozfate]

Gents,

As I macro going thru my works, I notice one more pattern.

Whereby when Dividend = 0, and additional >0, the macro will generate a dividend at sheet 2 without value, I would like the sheet 2 to not show any dividend.

I try play around with the code but no luck.

Wonder if anyone can help me again.

Thanks and regards

 

[GWteB]

I see ... how about:

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

Public Sub Chaozfate_r2()

    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)
        If arrSrc(3, j) <> 0 Then
            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)
        End If
        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]

I see ... how about:

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

Public Sub Chaozfate_r2()

    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)
        If arrSrc(3, j) <> 0 Then
            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)
        End If
        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

HolySmoke! Thank you GWteB for your prompt reply as always.

This solved my problems, I have been spending the whole afternoon trying to play around with the code. Guess the VBA talent is just not in my blood.

Appreciated.