Data Grab Macro

[Chris86t]

I have a excel sheet full of data. I need a macro that looks for where the RAG is Amber or Red and brings the information onto a separate tab.

The below table shows the source data this is on a tab called POAP DD-MM-YY (This date and tab will change every week)

CHANGE TYPE	ACTIVITY NAME	BUSINESS OWNER	TRANSITION TEAM OWNER	CRITICAL DEPENDENCIES/CONFLICTS	START DATE	PLANNED PROJECT HOURS	EXPECTED COMPLETION DATE	WEEKLY STATUS/UPDATE/ COMMENTS	WEEKLY RAG
data1	data1	data1	data1	data1	data1	data1	data1	data1	Amber
data2	data2	data2	data2	data2	data2	data2	data2	data2	Green
data3	data3	data3	data3	data3	data3	data3	data3	data3	Red

I then want the Macro to format the above data onto a new tab where the RAG says Amber or Red and looks like this

WEEKLY RAG	ACTIVITY NAME	BUSINESS OWNER	TRANSITION TEAM OWNER	WEEKLY STATUS/UPDATE/ COMMENTS
Amber	data1	data1	data1	data1
Red	data3	data3	data3	data3

Thanks

 

[VBE313]

Assuming your new tab is called "NewTab" and you already have the column headers in that tab, please see the following code. Make sure you run the macro when you are on the sheet that needs to be read.

Sub Chris86t1()
Application.ScreenUpdating = False
Dim cl As Object, lastRow As Long, ws As Worksheet
Dim weeklyRag As String, activityName As String, businessOwner As String, teamOwner As String, weeklyStatus As String
Set ws = ActiveSheet
    For Each cl In ActiveSheet.Range("J:J")
        If cl.Value = "Amber" Or cl.Value = "Red" Then
            weeklyRag = cl.Value
            activityName = cl.Offset(0, -8).Value
            businessOwner = cl.Offset(0, -7).Value
            teamOwner = cl.Offset(0, -6).Value
            weeklyStatus = cl.Offset(0, -1).Value
            Sheets("NewTab").Activate
            lastRow = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(lastRow, 1).Offset(1, 0).Select
            ActiveCell.Value = weeklyRag
            ActiveCell.Offset(0, 1).Value = activityName
            ActiveCell.Offset(0, 2).Value = businessOwner
            ActiveCell.Offset(0, 3).Value = teamOwner
            ActiveCell.Offset(0, 4).Value = weeklyStatus
            ws.Activate
        ElseIf cl.Value = "" Then
            Exit Sub
        End If
    Next cl
Application.ScreenUpdating = rue
End Sub

 

[DanteAmor]

Here another macro for you to consider.

Run the macro on your sheet with source data.
The macro assumes that the data starts in cell A2.

Sub Macro1()
  Dim a As Variant, b As Variant, i As Long, j As Long
  a = Range("A2", Range("J" & Rows.Count).End(xlUp))
  ReDim b(1 To UBound(a, 1), 1 To 5)
  j = 1
  For i = 1 To UBound(a, 1)
    Select Case a(i, 10)
      Case "Amber", "Red"
        b(j, 1) = a(i, 10)
        b(j, 2) = a(i, 2)
        b(j, 3) = a(i, 3)
        b(j, 4) = a(i, 4)
        b(j, 5) = a(i, 9)
        j = j + 1
    End Select
  Next
  Sheets.Add after:=Sheets(ActiveSheet.Index)
  Range("A1").Resize(1, 5).Value = Array("WEEKLY RAG", "ACTIVITY NAME", "BUSINESS OWNER", "TRANSITION TEAM OWNER", "WEEKLY STATUS/UPDATE/ COMMENTS")
  Range("A2").Resize(UBound(b), 5).Value = b
End Sub

 

[Chris86t]

Thanks both I will give them a whirl and let you know how I get on.

 

[DanteAmor]

Of course, let me know any doubt.