Solved: creating a summary report based on column data

[Sanchaz]

Hi. I'm at it again...trying to do something I don't know how to!

Anywho, I found a couple of pieces of code on this site that got me VERY close to what I want to accomplish (thanks to you all), but I'm having trouble massaging it to do what I want.

I have a set of project worksheets which are all formatted the same way (if I can keep my boss from changing them): same headers, same number of columns, all headers are in row 3 of worksheet, etc.

Here are the things I want to do:
For each worksheet:

• insert the worksheet name into the next available empty row in the Summary Report worksheet
• add headers for each worksheet extract
• copy rows to the Summary Report worksheet only if the date in the Deadline column falls w/in a date range.
• skip a row in the Summary Report worksheet between each data set

I've added comments in the code where I think the actions should take place. I've also attached the file I'm trying to automate. (OK, so the worksheets aren't all the same right now and they all don't have data, but I'm working with what I have now and will sync things before I finalize the project.)

Can someone help me put all the pieces together?

I'd be ever SOOOO GRATEFUL!!!!!

Here's the code I'm using:

[vba]
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 colCount As Integer 'Column count in tables in the worksheets

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

'Skip a row in Summary Report worksheet

'Put sheet name in next available cell in column A of Summary Report


'Retrieve column headers and put them in Summary Report (always in row 3 of worksheet)


'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))


'copy only those rows that match preset date range
'If value in column E >= Date And value in column E <= Date + 7 Then
'copy the row


'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht

'Resize the columns in Summary Report worksheet
trg.Columns("A").ColumnWidth = 35
trg.Columns("A").WrapText = True
trg.Columns("B").ColumnWidth = 50
trg.Columns("B").WrapText = True
trg.Columns("C").ColumnWidth = 15
trg.Columns("D").ColumnWidth = 15
trg.Columns("E").ColumnWidth = 15

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
[/vba]

[Sanchaz]

oops, i forgot to attach the .xls. No matter. It's just a set of sheets with 5 columns and an unknown number of rows for each.

[Bob Phillips]

I wasn't clear what all the code after the comments did, there seemed to be a dichotomy between headers starting in row 3 and data starting in row 21, so I left it alone.

UNTESTED.

[vba]


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 colCount As Integer 'Column count in tables in the worksheets
Dim rowCount As Long 'to get next row on summary sheet

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 Not sht.Index = wrk.Worksheets.Count 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 + 2, "A").Value = sht.Name

'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
sh.Cells(2, "A").Resize(, colCount).Copy trg.Cells(rowCount + 2, "B")
'========================================================================

'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))

'copy only those rows that match preset date range
'If value in column E >= Date And value in column E <= Date + 7 Then
'copy the row

'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht

'Resize the columns in Summary Report worksheet
trg.Columns("A").ColumnWidth = 35
trg.Columns("A").WrapText = True
trg.Columns("B").ColumnWidth = 50
trg.Columns("B").WrapText = True
trg.Columns("C").ColumnWidth = 15
trg.Columns("D").ColumnWidth = 15
trg.Columns("E").ColumnWidth = 15

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
[/vba]

[Sanchaz]

Thanks for the code for putting the sheet name into the Summary Report. It works beautifully.

Now, instead of pulling all the rows of data from each worksheet as it does now, I want to copy only those rows whose deadline date (in column E) fall within a 7-day period (i.e.: If value in column E >= Date And value in column E <= Date + 7 Then copy the row).

I assume you have to test each row to see if it meets the criterion, then copy and paste the valid rows one by one into the Summary Report. Would you get the range first, then do a For loop to check each row's deadline date and paste if it qualifies? I think I understand what I have to do, I just don't know the syntax well enough to actually do it. Every example I see, however, provides more clues. Thanks in advance for your continued help.

[Bob Phillips]

I would get the range, then loop through building a memory range of the rows that meet the criteria, and then copy that at the end.

[Sanchaz]

I know how to get the range of all rows from the worksheet, but how do I loop through the range to extract just the rows that meet my criteria?

I don't know how to find each row in the range that has a date that falls within a date range (Now to Now + 7. The date is in column E) and copy it into a new range. Once I know how to do this, I can copy the new range into the target worksheet.

I've looked through the forum, but can't find any code that looks right.

[Bob Phillips]

[vba]

IF Cells(i,"E").Value >=Date And .Cells(i,"E") < Date + 7 Then
'your stuff
[/vba]

[Sanchaz]

I've looked through the forum 'til I'm purple, but still can't figure out how to do this. (close only counts in horseshoes)

I've got the range.

Now I need the code to:

throw out all rows in the range whose deadline date (column E) is ""
throw out all rows that don't meet these criteria:Cells(i,"E").Value >=Date And .Cells(i,"E") < Date + 7

Once I've pared down the range, I have the code to paste the range into the summary spreadsheet.

Give an old girl a break and post the exact code to do this, PLEEEAAASE.

[Sanchaz]

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