Copy cell that contains values other than zero using macro in excel

Azrin

New Member
Joined
Mar 5, 2012
Messages
16
Hello everyone.

I'm a new Excel 2007 user and desperately in need of help regarding macro programming.

Right now, I have one worksheet that consists of several columns (A to J) with quite a number of rows as well. I desperately in need of help in building a macro that would enable me to copy specific cells based on its value to another sheet in the same workbook.

Th first two columns (A and B) contain students' IDs and names, whereas the rest of the columns contain the date of attendance.

Only cells that contains values other than zero and empty cells that should be copied and pasted.

I've tried quite q number of solutions from other members' questions as well as other forums but all end up in vain.

Below is how the first worksheet looks like:

Capture1.jpg


Below is how the copied sheet supposed to look like:

Capture2.jpg


I greatly hope that someone will response to this thread of mine.
Hehehe... :p

Thank you and have a nice day. :)
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

Beezkneez

Board Regular
Joined
Oct 23, 2008
Messages
123
I knocked this together quickly.

Code:
Sub AttendanceSummary()
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A2").Select
Dim X As Integer 'Column offset number
Dim Y As Integer 'Output sheet counter
Y = 2
Sheets("Sheet2").Range("A1").Value = "ID"
Sheets("Sheet2").Range("B1").Value = "Name"
Sheets("Sheet2").Range("C1").Value = "Date"
Sheets("Sheet2").Range("D1").Value = "Attendance"
Do Until ActiveCell.Value = 0
    X = 2
        Do Until IsEmpty(ActiveCell.Offset(0, X)) = True
            If ActiveCell.Offset(0, X).Value = 1 Then
                Sheets("Sheet2").Cells(Y, 1).Value = ActiveCell.Value 'Populate ID
                Sheets("Sheet2").Cells(Y, 2).Value = ActiveCell.Offset(0, 1).Value 'Populate Name
                Sheets("Sheet2").Cells(Y, 3).Value = Cells(1, X + 1).Value 'Populate Date
                Sheets("Sheet2").Cells(Y, 4).Value = 1 'Populate Attendance Count
                Y = Y + 1
            End If
            X = X + 1
        Loop
    ActiveCell.Offset(1, 0).Select
Loop
 
End Sub

It doesn't do any pretty formats but hopefully will help.
 

Tom Urtis

MrExcel MVP
Joined
Feb 10, 2002
Messages
11,241
One way:

Code:
Sub Test1()
Application.ScreenUpdating = False
Dim LastRow&, NextRow&, LastCol&, strSummary$, asn$, xRow&
asn = ActiveSheet.Name
NextRow = 2
strSummary = "zzzSummary"
Application.DisplayAlerts = False
On Error Resume Next
Sheets(strSummary).Delete
Err.Clear
Application.DisplayAlerts = True
Sheets.Add(After:=Sheets(Sheets.Count)).Name = strSummary
Range("A1:D1").Value = Array("ID", "Name", "Date", "Attendance")
With Sheets(asn)
With .Range("A1").CurrentRegion
LastRow = .Rows.Count
LastCol = .Columns.Count
End With
For xRow = 2 To LastRow
Range(Cells(NextRow, 1), Cells(NextRow + LastCol - 3, 1)).Value = .Cells(xRow, 1).Value
Range(Cells(NextRow, 2), Cells(NextRow + LastCol - 3, 2)).Value = .Cells(xRow, 2).Value
Range(Cells(NextRow, 3), Cells(NextRow + LastCol - 3, 3)).Value = Application.Transpose(Array(.Range(.Cells(1, 3), .Cells(1, LastCol))))
Range(Cells(NextRow, 4), Cells(NextRow + LastCol - 3, 4)).Value = Application.Transpose(Array(.Range(.Cells(xRow, 3), .Cells(xRow, LastCol))))
NextRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Next xRow
End With
Columns(4).Replace What:="0", Replacement:="", LookAt:=xlWhole
On Error Resume Next
Columns(4).SpecialCells(4).EntireRow.Delete
Err.Clear
Range(Columns(1), Columns(4)).AutoFit
Application.ScreenUpdating = True
End Sub
 

Azrin

New Member
Joined
Mar 5, 2012
Messages
16
Thank you so much to Beezkneez and Tom Urtis for that amazing solutions

Hello everyone especially to my saviours, Beezkneez and Tom Urtis. :)


Both of you are so amazing, the solutions work wonder.


I couldn't believe that this problem that has bugged me for the past couple of weeks can be worked out in a matter of less than a day by these two wonderful person. :)


Thank you so much for your help and I do hope that others people who stumble into the same problem like I did, will use both of the solutions provided Beezkneez and Tom Urtis because they worked like miracles. :biggrin:


Once again, thank you so much to both of you from me and all the teachers at my school.


P.S. - Both of you are my Excel warriors. Ever. :biggrin:
 

Azrin

New Member
Joined
Mar 5, 2012
Messages
16

ADVERTISEMENT

Ways to modify the code : Copy cell that contains values other than zero using macro in excel

Hi Tom and other board's members, :)


The code that you've provided worked amazing.

Code:
Sub Test1()
Application.ScreenUpdating = False
Dim LastRow&, NextRow&, LastCol&, strSummary$, asn$, xRow&
asn = ActiveSheet.Name
NextRow = 2
strSummary = "zzzSummary"
Application.DisplayAlerts = False
On Error Resume Next
Sheets(strSummary).Delete
Err.Clear
Application.DisplayAlerts = True
Sheets.Add(After:=Sheets(Sheets.Count)).Name = strSummary
Range("A1:D1").Value = Array("ID", "Name", "Date", "Attendance")
With Sheets(asn)
With .Range("A1").CurrentRegion
LastRow = .Rows.Count
LastCol = .Columns.Count
End With
For xRow = 2 To LastRow
Range(Cells(NextRow, 1), Cells(NextRow + LastCol - 3, 1)).Value = .Cells(xRow, 1).Value
Range(Cells(NextRow, 2), Cells(NextRow + LastCol - 3, 2)).Value = .Cells(xRow, 2).Value
Range(Cells(NextRow, 3), Cells(NextRow + LastCol - 3, 3)).Value = Application.Transpose(Array(.Range(.Cells(1, 3), .Cells(1, LastCol))))
Range(Cells(NextRow, 4), Cells(NextRow + LastCol - 3, 4)).Value = Application.Transpose(Array(.Range(.Cells(xRow, 3), .Cells(xRow, LastCol))))
NextRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Next xRow
End With
Columns(4).Replace What:="0", Replacement:="", LookAt:=xlWhole
On Error Resume Next
Columns(4).SpecialCells(4).EntireRow.Delete
Err.Clear
Range(Columns(1), Columns(4)).AutoFit
Application.ScreenUpdating = True
End Sub


Now, I only have one problem, do you know how to tweak the code so that the the summary's page would not be deleted and replaced with a new one?


This is due to archival factors.

Thanks and have a great day everyone. :)
 

Tom Urtis

MrExcel MVP
Joined
Feb 10, 2002
Messages
11,241
The question becomes, do you want

(A)
One single summary sheet and have all macro runs be such that the copied data is stacked below the existing previous data...

or

(B)
Do you want to manage the archiving requirements such that each macro run creates its own separate summary worksheet.
 

Azrin

New Member
Joined
Mar 5, 2012
Messages
16
Hi Tom, :)

Thanks for responding back.

I guess it will be the (A) option with a twist.

The solution that you've provided earlier is amazing and it just suits my requirement perfectly.

However, some teachers want the macro not to delete the existing summary sheet and create a new one.

This is probably because they applied some formatting to the summary sheets, I guessed. Such as row colours, etc...

Right now, I need your help in tweaking the code so that it wouldn't delete existing summary sheet and create new one but just replace the existing data with a new one.

Therefore, once the macro runs, the data inside the existing summary sheet will be replaced by new data while retaining the format applied to the summary sheet. For example, the column header...

Is that possible or I asking too much from you?

BTW, sorry for the late reply, I just survived cold. :p

Thank you. :)
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,132,685
Messages
5,654,745
Members
418,149
Latest member
amamiche67

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