It doesn't seem too bad, most times the msgbox shows 00:00:00 !
The filldown bit might be faster to do in blocks, instead of cell by cell, instead of:
For Each r In .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 3))
If r.Value = "" Then
r.FillDown
End If
Next r
you could test:
For Each are In .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 3)).SpecialCells(xlCellTypeBlanks).Areas
are.Offset(-1).Resize(are.Rows.Count + 1).FillDown
Next are
Deleting blank rows, it may not be faster but instead of:
For i = .UsedRange.Rows.Count To 1 Step -1
If Len(.Cells(i, 4)) = 0 Then .Rows(i).Delete
Next i
you could test (btw, Excel only looks at the usedrange here anyway, it doesn't need to be specified):
.Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
You use this sort of thing a few times:
.Range(.Cells(x + 1, 4), .Cells(x + 1, 4)).Resize(1, 38)…
where because the two .Cells(x + 1, 4) are the same cell you could use the simpler:
.Cells(x + 1, 4).Resize(1, 38)
All the above in:
Sub Transform_Data2()
Dim ws As Worksheet, ws2 As Worksheet
Dim x As Long, y As Long, i As Long
Dim r As Range, are As Range
Dim t0 As Date
Application.ScreenUpdating = False
t0 = Now
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "NewSheet" Then
Application.DisplayAlerts = False
Worksheets("NewSheet").Delete
Application.DisplayAlerts = True
End If
Next ws
Set ws2 = ThisWorkbook.Sheets.Add(Before:=Sheets(1))
ws2.Name = "NewSheet"
y = 2
For Each ws In ThisWorkbook.Worksheets
With ws
For x = 10 To LastOccupiedRowNum(ws)
If .Cells(x, 2) = "Department:" Then ws2.Cells(y, 1) = .Cells(x, 5)
If .Cells(x, 2) = "Employee Code:-" Then
ws2.Cells(y, 2) = .Cells(x, 11)
ws2.Cells(y, 3) = .Cells(x, 25)
.Cells(x + 1, 4).Resize(1, 38).Copy
ws2.Cells(y, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
.Cells(x + 4, 4).Resize(9, 38).Copy
ws2.Cells(y, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
ws2.Cells(y, 14) = .Cells(x + 3, 2)
y = LastOccupiedRowNum(ws2) + 1
End If
Next x
End With
Next ws
With ws2
.Range("A1:N1").Value = Array("Department", "Employee Code", "Employee Name", "Days", "Shift", "In Time", "Out Time", "Late By", "Early By", "Total OT", "Duration", "T Duration", "Status", "Remarks")
.Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For Each are In .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 3)).SpecialCells(xlCellTypeBlanks).Areas
are.Offset(-1).Resize(are.Rows.Count + 1).FillDown
Next are
.Range("A1:M2").Columns.AutoFit
End With
MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed"
Application.ScreenUpdating = True
End Sub