-
I finally hammered some code together that does what I want it to do. It may not be elegant, but it works:
Option Explicit
Sub CreateSummaryReport()
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 'Summary 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 Summary report and displays a msg if there is
For Each sht In wrk.Worksheets
If sht.Name = "Summary Report" Then
MsgBox "There is a worksheet called as 'Summary Report'." & vbCrLf & _
"Please remove or rename this worksheet since 'Summary Report' 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 = "Summary Report"
'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 Summary Report worksheet)
If sht.Index = wrk.Worksheets.count Then
Exit For
End If
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 Summary Report worksheet
rowCount = trg.Cells(trg.Rows.count, "A").End(xlUp).Row
'Put sheet name in next available cell in column A of Summary Report
trg.Cells(rowCount + 3, "A").Value = sht.Name
trg.Cells(rowCount + 3, "A").Font.Color = RGB(255, 0, 0)
trg.Cells(rowCount + 3, "A").Font.Bold = True
'Retrieve column headers and put them in Summary 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 summary report
sht.Cells(i, "E").EntireRow.Copy trg.Cells(65536, 1).End(xlUp).Offset(1)
End If
Next i
End If
Next sht
'Resize the columns in Summary 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
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules