Sorting Data - copy only needed data (macro)

[city]

Hi Friends!

Can someone help me out with my VB code. I have a sheet that contains raw data (sheet1) and I already created a macro that can delete all blanks and copy the data in sheet2. But Im really having trouble creating a macro which will get me the needed outcome (sample sheet). . .

I only need to copy the name of the employee from the raw data (sheet1) and its total of 1 (sheet1).


adherence_v2.xlsm


Also I have this problem that the macro that I created seem so slow. . . .

[city]

reposting. . .

[jindon]

Try

Sub test()
    Dim myAreas As Areas, i As Long
    On Error Resume Next
    Set myAreas = Sheets("sheet1").Columns("b").SpecialCells(2).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To myAreas.Count
        With myAreas(i)
            Sheets("sheet2").Cells(i + 1, 2).Value = .Cells(0, 0).Value
            .Rows(2).Offset(, 1).Resize(, .CurrentRegion.Columns.Count).Copy _
            Sheets("sheet2").Cells(i + 1, 3)
        End With
    Next
    Set myAreas = Nothing
    Application.ScreenUpdating = True
End Sub

[nilem]

Sub ertert()
Dim x, i&, j&, k&
With Sheets("Sheet1")
    x = .Range("A1:K" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With

For i = 1 To UBound(x)
    If x(i, 1) Like "Employee:*" Then
        j = j + 1: x(j, 1) = Trim(Split(x(i, 1), ":")(1))
    End If
    If x(i, 1) Like "Total of*" Then
        For k = 3 To UBound(x, 2): x(j, k - 1) = x(i, k): Next k
    End If
Next i

Sheets("Sheet2").Range("B2:K2").Resize(j).Value = x
End Sub

[city]

Thanks nilem and jindon!!! Both codes works perfectly! - Thanks so much masters! I added to your reputations by the way.