Macro to Copy non-zero values and paste it in a specific range

[kupseker]

Hey there,

I want a macro copying only non-zero values and pasting it to desired area.

My data look like this;

Form	Count
PL01	2
TL03	0
PR07	4
SR02	5

<tbody>
</tbody>

My new table should only include rows having nonzero values in Count column.
Form column values are unique but number of rows changes.

Thanks in advance.

 

[Fishboy]

Hey there,

I want a macro copying only non-zero values and pasting it to desired area.

My data look like this;

Form	Count
PL01	2
TL03	0
PR07	4
SR02	5

<tbody>
</tbody>

My new table should only include rows having nonzero values in Count column.
Form column values are unique but number of rows changes.

Thanks in advance.

Hi kupseker, welcome to the boards.

Without knowing more information I have had to speculate a little. Try out the following code in a COPY of your workbook. You did not specify where the pasting area is so I have temporarily made it columns D and E of the same sheet (although it will be simple enough to change as required). The code also automatically puts in the column headers in columns D and E respectively as this is used to work out the "last row" of the new table:

Sub CopyNonZeroValues()
' Defines variables
Dim Cell As Range, cRange As Range
' Puts header "Form" in cell D1 (amend as required)
Range("D1").Value = "Form"
' Puts header "Count" in cell E1 (amend as required)
Range("E1").Value = "Count"
' Defines LastRow1 as the last row of column B containing data
LastRow1 = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
' Defines LastRow2 as the first blank row beneath the new headers
LastRow2 = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1
    ' Sets the range to check as B2 to the last row of B
    Set cRange = Range("B2:B" & LastRow1)
        ' For each cell in the check range
        For Each Cell In cRange
            ' If the cell value is greater than zero then...
            If Cell.Value > 0 Then
                ' Copy the data from that row of the existing table to the next blank row in the new table
                Range("A" & Cell.Row, Cell).Copy _
                    Destination:=Range("D" & LastRow2)
                        ' Increase LastRow2 by 1 to account for the new row
                        LastRow2 = LastRow2 + 1
            End If
        ' Move to next cell in check range
        Next Cell
End Sub

 

[kupseker]

Thank you so much it helped a lot! Cheers!

 

[Fishboy]

Thank you so much it helped a lot! Cheers!

Happy to help.

 

[babasolai]

ur above macro helped a lot for me. but i need little modification in that. could u please help me. I have a table of data. In that, in some cells i used formula. I am pasting the table below for ur ref. i need to extract rows with non zero value based on column Qty & i need to paste it after 2 or 3 column. I need to paste values only as I have formulas in my table.

	Symbol	Qty	Price	volume
	TORNTPHARM	573​	0​	1234​
	TORNTPHARM	573​	0​	12​
	TORNTPHARM	0​	0​	1245​
	TORNTPHARM	276​	0​	1234​
	TORNTPHARM	100​	0​	345345​
	TORNTPHARM	100​	0​	123324​

 

[blankName]

Hi kupseker, welcome to the boards.

Without knowing more information I have had to speculate a little. Try out the following code in a COPY of your workbook. You did not specify where the pasting area is so I have temporarily made it columns D and E of the same sheet (although it will be simple enough to change as required). The code also automatically puts in the column headers in columns D and E respectively as this is used to work out the "last row" of the new table:

Sub CopyNonZeroValues()
' Defines variables
Dim Cell As Range, cRange As Range
' Puts header "Form" in cell D1 (amend as required)
Range("D1").Value = "Form"
' Puts header "Count" in cell E1 (amend as required)
Range("E1").Value = "Count"
' Defines LastRow1 as the last row of column B containing data
LastRow1 = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
' Defines LastRow2 as the first blank row beneath the new headers
LastRow2 = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1
    ' Sets the range to check as B2 to the last row of B
    Set cRange = Range("B2:B" & LastRow1)
        ' For each cell in the check range
        For Each Cell In cRange
            ' If the cell value is greater than zero then...
            If Cell.Value > 0 Then
                ' Copy the data from that row of the existing table to the next blank row in the new table
                Range("A" & Cell.Row, Cell).Copy _
                    Destination:=Range("D" & LastRow2)
                        ' Increase LastRow2 by 1 to account for the new row
                        LastRow2 = LastRow2 + 1
            End If
        ' Move to next cell in check range
        Next Cell
End Sub

Dude, THANK YOU so much...

I've registered this forum just to thank you. Dont know if you would see this answer ever, but you should know your soluition saved my whole life!

Thank you again!!!