Help to fine tune the codes | transform data, delete blank rows and then autofill

Dear Experts,

Request your help and advice to finetune my codes below to run it faster. I'm a beginner to VBA and still trying to learn a lot about it.
I have attached the workbook with 2 sample sheets. And the code works fine in copying the data from each sheet to a new sheet and then loops through the cells to delete the blanks and finally autofill the first 3 columns.

It takes some time to complete the task if I have large data and I assume that the last 2 steps (deleting blank rows and autofill) could be taking more time.
I can filter the dates column with blanks and then delete them to run it faster, but normally excel gets stuck if there are a greater number of rows and if the data is not sorted to have the blank cells in adjacent rows.

Thanks for your time and help and wish you a 'Merry Christmas and a Happy New Year'

Code:

---

Option Explicit

Sub Transform_Data()
    Dim ws As Worksheet, ws2 As Worksheet
    Dim x As Long, y As Long, i As Long
    Dim r 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)
                End If
                If .Cells(x, 2) = "Employee Code:-" Then
                    ws2.Cells(y, 2) = .Cells(x, 11)
                    ws2.Cells(y, 3) = .Cells(x, 25)
                    .Range(.Cells(x + 1, 4), .Cells(x + 1, 4)).Resize(1, 38).Copy
                    ws2.Range(ws2.Cells(y, 4), ws2.Cells(y, 4)).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                    .Range(.Cells(x + 4, 4), .Cells(x + 4, 4)).Resize(9, 38).Copy
                    ws2.Range(ws2.Cells(y, 5), 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   
    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")   
    With Sheets("NewSheet")
        For i = .UsedRange.Rows.Count To 1 Step -1
            If Len(.Cells(i, 4)) = 0 Then .Rows(i).Delete
        Next i       
        For Each r In .Range(.Cells(2, 1), .Cells(.UsedRange.Rows.Count, 3))
            If r.Value = "" Then
                r.FillDown
            End If
        Next r
        .Range("A1:M2").Columns.AutoFit
    End With
    MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed"
    Application.ScreenUpdating = True   
End Sub


Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng    As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", _
            after:=.Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function

---

In re: Deleting "NewSheet"

Code:

---

On Error GoTo NoNewSheet
  If Sheets("NewSheet").Name = "NewSheet" Then
      Application.DisplayAlerts = False
      Worksheets("NewSheet").Delete
      Application.DisplayAlerts = True
  End If
NoNewSheet:

---

It's always faster to work in RAM vice working with an actual Worksheet

Code:

---

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As worksheet

For each ws in Worksheets
  ws1.Cells = ws.Cells
  With ws1
      '.Do all that you do with ws, (and ws2,) but do it with ws1
      '
      '
  End with
Next ws

---

'Instead of working on Sheets("NewSheet") keep working on the RAM Sheet "ws2"
Only when completely done creating and formatting ws2, Add "NewSheet" to the collection and then set it equal to ws2

Code:

---

    Sheets.Add(Before:=Sheets(1) Name = "NewSheet"
    ws2.UsedRange.Copy Sheets("NewSheet").Range("A1")
Application.ScreenUpdating = True 'etcEnd sub

---

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:

Code:

---

  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:

Code:

---

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:

Code:

---

  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):

Code:

---

  .Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

---

You use this sort of thing a few times:

Code:

---

.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:

Code:

---

.Cells(x + 1, 4).Resize(1, 38)

---

All the above in:

Code:

---

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

---

Thanks SamT

Thanks a lot p45cal