Data transfer depending on the empty cells

[joky]

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]

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]

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]

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]

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