Display List Of Open Items

[Justair07]

Hello everyone,

I want to create a workbook that will track "Open" items that are past the due date from project events. I attached a sample workbook to better explain my intentions. There are 4 worksheets. 3 of the worksheets are for different events and 1 worksheet (Summary) to display all open items (Event Name, Task, Status, Date, Responsible Person, and Manager) from all three events. Not all the open items need to be listed, only the ones that are currently past due.

I'm hoping to have an easy way to do this. I'm not sure if I have to use a macro or not. If so, one important factor is that I will be adding new Event worksheets every week and I will need the macro to search them as well.

I hope my explanation made sense. Please take a look at my sample for clarification.

Thank you in advance to anyone willing to take a look at this for me.

- Justin

[MarvinP]

Hi Justin,

There is an old tool called the Pivot Table Wizard that "consolidates" regions into a single pivot table. See the attached where I've tried to see if it would solve your problem.

See how to add this wizard to your QAT at:
http://www.pivot-table.com/2010/07/1...in-excel-2007/

Hope this helps.

[boopathiraja]

@ Marvin is there any way to change the data source like standard pivot table ?

[Justair07]

Hi Justin,

There is an old tool called the Pivot Table Wizard that "consolidates" regions into a single pivot table. See the attached where I've tried to see if it would solve your problem.

See how to add this wizard to your QAT at:
http://www.pivot-table.com/2010/07/1...in-excel-2007/

Hope this helps.

Hi Marvin,

How do I change the Number Format. For example I want the Date to be a Date and Names to be Text. It seems to be as if you can only set one type of format.

[MarvinP]

Using the Consolidation Wizard you add the sources of the data.
See an example of what I mean at
http://blog.executivetrainingsolutio...ltiple-ranges/

[Justair07]

After doing more research I've realize I need a macro lol

[trisoldee]

I'm sure there's a better way to do it but here's something that I put together based on something I already had.

Delete the blank summary tab you have, insert in Column A on each tab a column for "Event", then run this and delete anything that's already closed which should sort to the top and you'll be left with a list sorted by "Event" then by "Due Date".

One problem that I came across that maybe someone else can help with is how to get the range to be a dynamic selection so in the event that you go passed a certain number of lines it will still pick it up. I'm sure there's also a way to get it to delete anything that has data in the date closed column for you but this is hopefully a start that get's you moving in the right direction.

Sub MergeSheets()
'''''''''''''''''''''''''''''''''''''''''''''''''
'Copy data from all Worksheets to a new Worksheet
'''''''''''''''''''''''''''''''''''''''''''''''''
Dim intI, intSheetsCount As Integer
Dim blnFirstCopyComplete As Boolean
Dim NewSheet As Worksheet
Dim rngRange As Range
Dim lngLastRow
'Create a new Worksheet and move it before all Worksheets
Set NewSheet = ActiveWorkbook.Worksheets.Add(Before:=Worksheets(1))
'Get the number of Worksheets
intSheetsCount = ActiveWorkbook.Worksheets.Count
'Excluding the new Worksheet, copy all other Worksheets
'one by one
For intI = 2 To intSheetsCount
   
   'This is the Range that will be copied to the new Worksheet
   With ActiveWorkbook.Worksheets(intI)
      Set rngRange = .Range(.Cells(1, 1), _
         .Cells.SpecialCells(xlCellTypeLastCell))
   End With
   
   With NewSheet
      'If this is the first paste, do it on the first row
      If Not blnFirstCopyComplete Then
         rngRange.Copy Destination:=.Cells(1, 1)
         blnFirstCopyComplete = True
      'Else, first find the cell where the copied range will be
      'pasted and proceed with the paste
      Else
         'This is last row of the so far created new Worksheet data
         lngLastRow = .Range(.Cells(1, 1), _
            .Cells.SpecialCells(xlCellTypeLastCell)).Rows.Count
         'Do the paste on the next row
         rngRange.Copy Destination:=.Cells(lngLastRow + 1, 1)
      End If
   End With
Next 'intI

    ActiveSheet.Name = "Summary"
    Worksheets("Summary").Columns("a:g").AutoFit
    Cells.Select
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("d2:d500000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Summary").Sort
        .SetRange Range("A1:g500000")
        .HEADER = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("a2:a500000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Summary").Sort
        .SetRange Range("A1:g500000")
        .HEADER = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Summary").Sort.SortFields.Add Key:=Range("e2:e500000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Summary").Sort
        .SetRange Range("A1:g500000")
        .HEADER = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[Justair07]

Unfortunately the code doesn't quite do the trick but I appreciate you sharing. Hopefully someone will come along with a different approach.

[Justair07]

Hello everyone, just wondering if anyone with some VBA expertise had a chance to look at this problem for me? I would greatly appreciate any help I can get.

[Justair07]

Okay here is what I have so far:

Sub CopyRowsAcross()

Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Event A")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Summary")

For i = 2 To ws1.Range("B65536").End(xlUp).Row
If ws1.Cells(i, 2) = "Open" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i

End Sub

It works as far as coping the data is concerned but I need the macro to check all the worksheets in the workbook, not just the one that is defined. New workbooks will be created all the time.

[Justair07]

Okay I figured it out. Here it is if anyone else might be able to benefit from it.

Sub test1()

Dim i As Integer
Dim ws1 As Worksheet
Dim wrksht As Worksheet

Set ws1 = ThisWorkbook.Sheets("Summary")

For Each wrksht In ActiveWorkbook.Worksheets

If wrksht.Name <> "Summary" Then


    For i = 2 To wrksht.Range("B65536").End(xlUp).Row
        If wrksht.Cells(i, 2) = "Open" Then wrksht.Rows(i).Copy ws1.Rows(ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row + 1)
    Next i
    
    Else
    End If
Next wrksht

End Sub

Thanks self!