PDA

View Full Version : Data transfer depending on the empty cells



joky
01-15-2018, 10:45 AM
Hello everyone
I have this code to transfer data based on empty cells in column 4 With the deletion of rows that were moved from the main sheet Which works well with small data But testing for large data in the original file, it took about 50 - 65 seconds ... How can I improve this code to make it faster
Thanks advanced for help

Dave
01-15-2018, 04:11 PM
Joky U can trial this in your module code. HTH. Dave

Option Explicit
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Sub vbaexpress()
Dim cnt As Integer
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Sheets("result").UsedRange.ClearContents 'EntireRow.Delete
With Sheets("main")
.Range("A1:H2").Copy Sheets("result").Range("A1")
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
On Error GoTo ExitHere
.Range("D3:D" & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Copy _
Sheets("result").Cells(Rows.Count, 1).End(xlUp).Offset(1)
For cnt = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
If .Cells(cnt, 4).Value = vbNullString Then
Rows(cnt).Offset(1).EntireRow.Delete
End If
Next cnt
End With
ExitHere:
Sheets("result").Activate
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Application.Cursor = xlDefault
End Sub

joky
01-15-2018, 04:48 PM
Thank you so much Dave
I have tested the original file at 25000 but the file has become very slow


I appreciate a lot your sharing in my issues ...

I welcome any ideas to improve the code
Thanks advanced for help

offthelip
01-15-2018, 05:06 PM
As I have explained many times on this forum, one of the main reaons that Vba is slow is the time taken to access the worksheet from VBa is often the bottleneck.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action. So instead of writiing a loop which loops down a range deleting one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), delete all the data ( one worksheet access) then copy the lines to two different array depending on whether they are going back to resuults or main and then write the two arrays back ( two more worksheet accesses), total number of worksheet accesses 4, instead of the multiple accesses in the code above.
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.

Note if you have set range variable to a worksheet range you are still accessing the worksheet so it will be slow.


This code does this and it will run superfast regardless on the number of lines of code.



Sub superfast()
dim inarr as variant
dim mainarr as variant
dim resultarr as variant
Sheets("result").UsedRange.EntireRow.Delete

With Worksheets("main")
lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
' load data into a variant array
inarr = Range(.Cells(1, 1), .Cells(lastrow, 8))
' clear the worksheet
Range(.Cells(2, 1), Cells(lastrow, 8)) = ""
'load the two output arrays with headers and blank cells
mainarr = Range(.Cells(1, 1), .Cells(lastrow, 8))
resultarr = Range(.Cells(1, 1), .Cells(lastrow, 8))
mn = 3
rs = 3
' loop round all the data
For i = 3 To lastrow
' test if col D is blank
If inarr(i, 4) = "" Then
' copy to Results
For k = 1 To 8
resultarr(rs, k) = inarr(i, k)
Next k
rs = rs + 1
Else
'copy to main
For k = 1 To 8
mainarr(mn, k) = inarr(i, k)
Next k
mn = mn + 1
End If
Next i
' write the main sheet out
Range(.Cells(1, 1), .Cells(lastrow, 8)) = mainarr
End With
With Worksheets("result")
' wite the results sheet out
Range(.Cells(1, 1), .Cells(lastrow, 8)) = resultarr
End With
End Sub






Note: you will probably have to declare a whole load variables becasue I never use option explicit. I grew up before it existed and I find it a pain in the neck
all my varinable should be self explanatory

joky
01-16-2018, 09:14 AM
Thank you very much Mr. offthelip for this perfect solution
Thank you very much for this useful information. I appreciate that a lot
Best Regards from the deep of my heart