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

[Azrin]

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:

Below is how the copied sheet supposed to look like:

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

Thank you and have a nice day.

 

[Beezkneez]

I knocked this together quickly.

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]

One way:

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]

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.


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.

 

[Azrin]

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.

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]

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]

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.

Thank you.