anish.ms
12-23-2022, 07:41 PM
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
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