Solved: flaw in my code - creating a summary report

[Sanchaz]

Hi all.

I thought I'd solved all my issues with this code, but discovered a flaw. I count the number of rows that meet my criteria. This piece of code works fine. However, when I go to copy rows to my summary report, it skips the 4th and 6th rows, even though they meet the criteria. I don't know why this happens. :bug:

Could you look at my code and see if you see anything?

Thanks!


Option Explicit
Sub CreateWeeklyReport()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'report Worksheet
Dim rng As Range 'Range object
Dim rng2 As Range 'Range object
Dim iLastRow As Long
Dim colCount As Integer 'Column count in tables in the worksheets
Dim rowCount As Integer 'Row count in tables in the worksheets
Dim rowCount2 As Integer 'Row count in tables in the worksheets
Dim i As Long
Dim count As Integer
Set wrk = ActiveWorkbook 'Working in active workbook

'Checks for an existing report and displays a msg if there is
For Each sht In wrk.Worksheets
If sht.Name = "Due This Week" Then
MsgBox "There is a worksheet called as 'Due This Week'." & vbCrLf & _
"Please remove or rename this worksheet since 'Due This Week' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.count))
'Rename the new worksheet
trg.Name = "Due This Week"
'put title at top of worksheet
With trg.Cells(1, "A")
.Value = "Project Tasks Due This Week"
.Font.Bold = True
.Font.Size = 12
End With

'Point to first worksheet in workbook
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column

'Start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is the report worksheet)
If sht.Index = wrk.Worksheets.count Then
Exit For
End If

'count matching rows
rowCount2 = sht.Cells(sht.Rows.count, "A").End(xlUp).Row
count = 0
For i = 4 To rowCount2
'if deadline date meets criteria
If sht.Cells(i, "E").Value >= Date And sht.Cells(i, "E").Value <= Date + 7 Then
count = count + 1
End If
Next i

If count > 0 Then
'Skip a row in report worksheet
rowCount = trg.Cells(trg.Rows.count, "A").End(xlUp).Row
'Put sheet name in next available cell in column A of report
With trg.Cells(rowCount + 3, "A")
.Value = sht.Name
.Font.Color = RGB(255, 0, 0)
.Font.Bold = True
End With
trg.Cells(rowCount + 3, "B") = "Number of tasks: " & count

'Retrieve column headers and put them in report (always in row 3 of worksheet)
colCount = sht.Cells(3, sht.Columns.count).End(xlToLeft).Column
sht.Cells(3, "A").Resize(, colCount).Copy trg.Cells(rowCount + 4, "A")
'cycle through rows in spreadsheet
For i = 4 To rowCount2
'if deadline date meets criteria
If sht.Cells(i, "E").Value >= Date And sht.Cells(i, "E").Value <= Date + 7 Then
'copy row to report
sht.Cells(i, "A").EntireRow.Copy trg.Cells(65536, 1).End(xlUp).Offset(1)
End If
Next i
End If
Next sht

'Resize the columns in report worksheet
With trg
Columns("A").ColumnWidth = 35
Columns("A").WrapText = True
Columns("B").ColumnWidth = 50
Columns("B").WrapText = True
Columns("C").ColumnWidth = 15
Columns("D").ColumnWidth = 15
Columns("E").ColumnWidth = 15
Columns("C").VerticalAlignment = xlTop
Columns("D").VerticalAlignment = xlTop
Columns("E").VerticalAlignment = xlTop
End With

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[rory]

You appear to have two problems:
1. You are getting your rowcount variables based on the last used row in column A of each sheet, but there is not always text in column A for each task, so you are not necessarily looking at all the rows of data. You would be better off using column B, if there will always be task data.
2. When you copy rows, you have the same problem: if you copy a task row with no data in column A, then the next copy/paste occurs over the top of this row because your code looks at the last used row in A on the destination sheet.

[Sanchaz]

Updated code follows:


Option Explicit
Sub CreateWeeklyReport()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'report Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Dim rowCount As Integer 'Row count in tables in the worksheets
Dim rowCount2 As Integer 'Row count in tables in the worksheets
Dim i As Long
Dim countMe As Integer
Set wrk = ActiveWorkbook 'Working in active workbook

'Checks for an existing report and displays a msg if there is
For Each sht In wrk.Worksheets
If sht.Name = "Due Tomorrow" Or sht.Name = "Due Today" Or sht.Name = "Due This Week" Then
MsgBox "Please delete all report worksheets before running a new report.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Due This Week"
'put title at top of worksheet
With trg.Cells(1, "A")
.Value = "Project Tasks Due This Week"
.Font.Bold = True
.Font.Size = 12
End With

'Point to first worksheet in workbook
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column

'Start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is the report worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If

rowCount2 = sht.Cells(sht.Rows.Count, "E").End(xlUp).Row
countMe = 0
For i = 4 To rowCount2
'if deadline date meets criteria
If sht.Cells(i, "E").Value >= Date And sht.Cells(i, "E").Value <= Date + 7 Then
countMe = countMe + 1
End If
Next i

If countMe > 0 Then
rowCount = trg.Cells(trg.Rows.Count, "E").End(xlUp).Row
'Skip a row in report worksheet
'Put sheet name in next available cell in column A of report
With trg.Cells(rowCount + 2, "A")
.Value = sht.Name
.Font.Color = RGB(255, 0, 0)
.Font.Bold = True
End With
trg.Cells(rowCount + 2, "B") = "Number of tasks due this week for this project: " & countMe
'trg.Cells(rowCount + 2, "C") = "Number of rows in worksheet: " & rowCount2

'Retrieve column headers and put them in report (always in row 4 of worksheet)
colCount = sht.Cells(4, sht.Columns.Count).End(xlToLeft).Column
sht.Cells(4, "A").Resize(, colCount).Copy trg.Cells(rowCount + 3, "A")
'format the headings
With trg.Cells(rowCount + 3, "A").Resize(, colCount)
.Font.Bold = True
.Font.Size = 10
End With
'cycle through rows in spreadsheet
For i = 5 To rowCount2
'if deadline date meets criteria
If sht.Cells(i, "E").Value >= Date And sht.Cells(i, "E").Value <= Date + 7 Then
'copy row to report
rowCount = trg.Cells(trg.Rows.Count, "E").End(xlUp).Row
sht.Cells(i, "A").Resize(, colCount).Copy trg.Cells(rowCount + 1, "A")
'format the matching rows
With trg.Cells(rowCount + 1, "A").Resize(, colCount)
.Font.Bold = False
.Font.Size = 10
.Font.Color = RGB(0, 0, 0)
End With
End If
Next i
End If
Next sht
'Resize the columns in report worksheet
With trg
Columns("A").ColumnWidth = 35
Columns("A").WrapText = True
Columns("B").ColumnWidth = 50
Columns("B").WrapText = True
Columns("C").ColumnWidth = 15
Columns("D").ColumnWidth = 15
Columns("E").ColumnWidth = 15
Columns("C").VerticalAlignment = xlTop
Columns("D").VerticalAlignment = xlTop
Columns("E").VerticalAlignment = xlTop
End With

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[rory]

Is there a question? Same issue, or different one (or none)?

[Sanchaz]

No question. I was just trying to post the final code for this issue. Thanks for your help.