Pick up data based on conditions

akulka58

New member
Joined
May 1, 2015
Messages
1
Reaction score
0
Points
0
Hi All,
I need to automate below task. I have multiple sheets where team where team member’s achievements mentioned. In sample workbook I have added 2 sheets only however I have around 10 to 15 sheets in actual. I need to build matrix where below things should come up.


  1. If any team member have achievement then only macro or formula should pick up data (Please refer column Achievements)
  2. If achievement in same or in same month or in same date it should NOT skip. It must appear in output data
  3. In raw data (Sheet DR & TL)columns can be changed hence it should not affect our result

Please refer attached workbook for the same. Please help me how can solve this issue.
 

Attachments

  • Achievements.xlsx
    10.4 KB · Views: 15
Code:
Public Sub MergeData()
Dim ws As Worksheet
Dim col As Long
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long
    
    Application.ScreenUpdating = False
    
    With ActiveWorkbook
        
        Application.DisplayAlerts = False
        On Error Resume Next
        .Worksheets("Achievements").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
        ActiveSheet.Name = "Achievements"
        ActiveSheet.Range("A1:C1").Value = Array("OWNER", "Achievements/Milestone", "Date")
        
        nextrow = 2
        For Each ws In .Worksheets
    
            If ws.Name <> "Achievements" Then
            
                lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                col = Application.Match("OWNER", ws.Rows(1), 0)
                ws.Cells(2, col).Resize(lastrow - 1).Copy ActiveSheet.Cells(nextrow, "A")
                col = Application.Match("Achievements/Milestone", ws.Rows(1), 0)
                ws.Cells(2, col).Resize(lastrow - 1).Copy ActiveSheet.Cells(nextrow, "B")
                col = Application.Match("Date", ws.Rows(1), 0)
                ws.Cells(2, col).Resize(lastrow - 1).Copy ActiveSheet.Cells(nextrow, "C")
                col = Application.Match("Achievements", ws.Rows(1), 0)
                ws.Cells(2, col).Resize(lastrow - 1).Copy ActiveSheet.Cells(nextrow, "D")
                nextrow = nextrow + lastrow - 1
            End If
        Next
        
        With ActiveSheet
            
            lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
            For i = lastrow To 2 Step -1
            
                If .Cells(i, "D").Value <> "YES" Then
                
                    .Rows(i).Delete
                End If
            Next i
            
            .Columns("A:C").ColumnWidth = 20
            .Columns("D").Delete
        End With
    End With
    
    Application.ScreenUpdating = True
End Sub
 
Back
Top