Then try this...
Sub CopyDataToSheet1()
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, dlr As Long, n As Long
Dim critDate As Double
Dim Col
Dim Ans As String
Application.ScreenUpdating = False
Set sws = Sheets("Attendance")
Set dws = Sheets("Sheet1")
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
Ans = MsgBox("Do you want to clear the existing data on Sheet1?", vbQuestion + vbYesNo)
If Ans = vbYes Then dws.Range("A1").CurrentRegion.Offset(1).Clear
critDate = sws.Range("B3").Value
Col = Application.Match(critDate, sws.Rows(8), 0)
If Not IsError(Col) Then
sws.AutoFilterMode = False
With sws.Rows(8)
.AutoFilter field:=Col, Criteria1:="Present"
If sws.Range("A8:A" & slr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
n = sws.Range("A9:A" & slr).SpecialCells(xlCellTypeVisible).Cells.Count
sws.Range("A9:A" & slr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A" & Rows.Count).End(3)(2)
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
dws.Range("B" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B1").Value
dws.Range("C" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B2").Value
dws.Range("D" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B3").Value
dws.Range("E" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B4").Value
dws.Range("F" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B5").Value
dws.Range("G" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B6").Value
dws.Range("H" & Rows.Count).End(3)(2).Resize(n).Value = sws.Range("B7").Value
.AutoFilter
End If
End With
End If
Application.ScreenUpdating = True
End Sub
Bookmarks