Sanchaz
08-07-2007, 11:31 AM
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
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