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

[anish.ms]

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'



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

[SamT]

In re: Deleting "NewSheet"

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

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

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

[p45cal]

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

[anish.ms]

Thanks SamT (http://www.vbaexpress.com/forum/member.php?6494-SamT)

[anish.ms]

Thanks a lot p45cal (http://www.vbaexpress.com/forum/member.php?3494-p45cal)