Thread: Updating to a report worksheet

I have multiple worksheets that i use to track deficiency reports. I cant post the workbook due to security concerns. While they are being answered, they remain in an open status and are tracked by a second "Outstanding" worksheet. I have been updating this worksheet manually before our morning meetings. I am trying to automate the updating of this outstanding sheet based on data input on other sheets. Basically i have set it up using functions to flag a row as Outstanding or closed.
I have the code to delete the closed from the outstanding report taken care of already. The copy and paste from other sheets lets call them 736, 740, 742 to the outstanding sheet is what im having issues with.

Here is what i have now:

Sub UpdateTracker()

Set i = Sheets("CIF")
Set e = Sheets("Outstanding")
Dim d
Dim j

d = 1
j = 2

Do Until IsEmpty(i.Range("Q" & j))

If i.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value


End If
j = j + 1
Loop

End Sub

This works fine for exporting one worksheet to another, but when I try and modify it to update from all of the worksheets in the workbook at once, it doesn’t work.

Here is another approach I thought might work but I haven’t been able to utilize properly.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim wks As Worksheet

   Dim intRow As Integer

   If Target.Column <> 4 Then Exit Sub

   If IsEmpty(Target) Then Exit Sub

   On Error Resume Next

   Set wks = Worksheets(Target.Value)

   If Err > 0 Or wks Is Nothing Then

      MsgBox "Sheet name Not Found!"

      Exit Sub

   End If

   On Error GoTo 0

   With wks

      intRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1

      .Range(.Cells(intRow, 1), .Cells(intRow, 3)).Value = _

         Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Value

   End With

   Rows(Target.Row).Delete

End Sub

There are 7 worksheets that must update to one tracker, Any thoughts?

I got my code working perfectly on my own. It autoupdates when i enter an item, when i close an item it deletes it, and i threw in a sorting routing. Now, anyone care to help me clean up this mess? I'm still new at this and while i am sure i can setup some sort of array, id appreciate some pointers.

Private Sub Worksheet_Activate()


Set m = Sheets("CIF")
Set r = Sheets("723")
Set s = Sheets("728")
Set t = Sheets("729")
Set u = Sheets("732")
Set v = Sheets("734")
Set w = Sheets("736")
Set k = Sheets("738")
Set l = Sheets("740")
Set i = Sheets("742")
Set e = Sheets("Outstanding")

Dim d
Dim j

d = 1
j = 1

Do Until IsEmpty(i.Range("Q" & j))

If i.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value

End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(r.Range("Q" & j))

If r.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = r.Rows(j).Value

End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(s.Range("Q" & j))

If s.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = s.Rows(j).Value

End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(t.Range("Q" & j))

If t.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = t.Rows(j).Value

End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(u.Range("Q" & j))

If u.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = u.Rows(j).Value


End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(v.Range("Q" & j))

If v.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = v.Rows(j).Value


End If

j = j + 1
Loop

j = 1

Do Until IsEmpty(w.Range("Q" & j))

If w.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = w.Rows(j).Value


End If
j = j + 1
Loop

j = 1

Do Until IsEmpty(k.Range("Q" & j))
If k.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = k.Rows(j).Value

End If
j = j + 1
Loop

j = 1

Do Until IsEmpty(l.Range("Q" & j))
If l.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = l.Rows(j).Value

End If
j = j + 1
Loop

j = 1

Do Until IsEmpty(m.Range("Q" & j))
If m.Range("Q" & j) = "Outstanding" Then
d = d + 1
e.Rows(d).Value = m.Rows(j).Value

End If
j = j + 1
Loop

d = d + 1
Do Until IsEmpty(e.Range("A" & d))
e.Rows(d).Value = ""

d = d + 1

Loop

Dim StRw As Integer, EndRw As Integer
    StRw = 2 ' Starting Row
    EndRw = Range("E65500").End(xlUp).Row
    Rows(StRw & ":" & EndRw).Select
    Selection.Sort Key1:=Range("E2"), Order1:=xlAscending

End Sub