VBA to insert a duplicate row based on criteria

Chaozfate

Board Regular
Joined
Mar 15, 2017
Messages
58
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:
NumberAdditionalDividend
A00010500
B0002100600

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:
NumberParticularAmount
A0001Dividend500
B0002Dividend600
B0002Additional100

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

Thanks!
 

Chaozfate

Board Regular
Joined
Mar 15, 2017
Messages
58
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
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
I see ... how about:

VBA Code:
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
 
Solution

Chaozfate

Board Regular
Joined
Mar 15, 2017
Messages
58
I see ... how about:

VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,132,912
Messages
5,655,912
Members
418,250
Latest member
Jebacmakro

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top