EXCEL VBA to deal amount data , how to filter data and copy paste to another sheet faster?

Question

I have an CVS file that have amount of data over hundred thousands. Because the data file have many space not regular, I used filter "space" to filter one by one columns. After filter, I copy this column and paste to another sheet. I do those steps until the column data end. My file have many columns and hundreds thousand rows, but after filter "space" that about 100 thousands. But now I had a problem, I had wait too long about 5 minutes to finish this wrok. How could I run faster? I try to use Selection.SpecialCells(xlCellTypeVisible).Copy, took more time. Thanks!

Below is my excel VBA filter space and copy paste code

Sub FilterData()

    On Error GoTo ErrorHandler

    Dim AddSheetName As String
    Dim CSVNoExtensionName As String

    Dim LastColumn As Long
    Dim FinalRow As Variant

    Dim idxDataCol, idxPasteCol As Integer

    Dim sDelayTime As String

    sDelayTime = "02"

    AddSheetName = "sheet1"

    Dim Time0#
    Time0 = Timer      

    Workbooks(CSVDataFileName).Activate  

    If InStr(CSVDataFileName, ".") > 0 Then
        CSVNoExtensionName = Left(CSVDataFileName, InStr(CSVDataFileName, ".") - 1)
    End If

    Sheets.Add(After:=ActiveSheet).Name = AddSheetName

    Worksheets(CSVNoExtensionName).Activate

    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column   
    FinalRow = Range("A1").End(xlDown).Row    

    idxPasteCol = 1  

    For idxDataCol = 2 To LastColumn Step 1

        Cells(1, idxDataCol).Select

        Selection.AutoFilter
        ActiveSheet.Range(Cells(1, 1), Cells(FinalRow, LastColumn)).AutoFilter Field:=idxDataCol, Criteria1:="<>"

        Dim rng1, rng2 As Range
        Set rnge2 = Range(Cells(1, idxDataCol), Cells(FinalRow, idxDataCol))
        Set rng1 = Union(Range("A1:A" & FinalRow), rnge2)
        rng1.Select
        Selection.Copy        

        Application.Wait (Now + TimeValue("0:00:" & sDelayTime))

        Sheets(AddSheetName).Select
        ActiveSheet.Cells(1, idxPasteCol).Select
        ActiveSheet.Paste

        Columns(idxPasteCol).Font.ColorIndex = 41

        Sheets(CSVNoExtensionName).Select
        Application.CutCopyMode = False
        Selection.AutoFilter

        idxPasteCol = idxPasteCol + 2

    Next idxDataCol

    ActiveSheet.Cells(1, 1).Select

    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs FileName:=CSVNoExtensionName & ".xlsx", FileFormat:=xlOpenXMLStrictWorkbook, CreateBackup:=False

    Exit Sub   

End Sub

Try to [avoid using Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) and `Activate`. — BigBen, Jul 09 '19 at 03:53
Possible duplicate of [Speeding up VBA Code to Run Faster](https://stackoverflow.com/questions/44763554/speeding-up-vba-code-to-run-faster) — Mikku, Jul 09 '19 at 04:04

Ahmed AU · Answer 1 · 2019-07-09T07:45:38.247

Couldn't clearly understand, how you want to filter "space". Assumption (from code) that objective is to filter out any lines containing Blank or Blank space, I would like to do it directly reading from and writing to text file.

Moreover if the assumption is correct, the commands Select, Activate etc within the code increase operating time. Also operating in loop for each column is fine, but think union range method is unnecessary. After applying filter to all the columns the whole data area could be copied and pasted. But that may also widen up possibility of 1004 Error "Ms excel cannot create or use data range reference because it is too complex" as here data to be dealt with is more than 100 K.

So i tried with a data over 150 K rows X 50 columns directly, It takes 20 odd seconds to process the data as text file and another 20 seconds to open the resulted CSV file and save it as xlsx. The File format used in code is giving some problem (at least in Excel 2007) so i saved it directly as xlsx.

Sub test()
Dim oFlNo As Integer, iFlNo As Integer
Dim oFlName As String, iFlName As String
Dim oFolder As String, iFolder As String
Dim Arr As Variant, HaveBlank  As Boolean
Dim Tm As Double

Tm = Timer
iFlName = "C:\users\user\desktop\FilerCSv.Csv"
oFlName = "C:\users\user\desktop\FilteredCSv.Csv"

iFlNo = FreeFile
Open iFlName For Input As #iFlNo
oFlNo = FreeFile
Open oFlName For Output As #oFlNo


        Do While Not EOF(iFlNo)    ' Loop until end of file.
        Line Input #iFlNo, Ln    ' Read line into variable.
        Arr = Split(Ln, ",")
        HaveBlank = False
            For Each xVal In Arr
            xVal = Trim(xVal)
                If xVal = "" Then
                HaveBlank = True
                Exit For
                End If
            Next
            If HaveBlank = False Then
            Write #oFlNo, Ln
            End If
        Loop
    Close #iFlNo
    Close #oFlNo
Debug.Print Timer - Tm

Workbooks.Open (oFlName)
oFlName = Left(oFlName, Len(oFlName) - 4)
ActiveWorkbook.SaveAs Filename:=oFlName & ".xlsx"   ', FileFormat:=xlOpenXMLStrictWorkbook, CreateBackup:=False
Debug.Print Timer - Tm

End Sub

Since I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques on your discretion.

EXCEL VBA to deal amount data , how to filter data and copy paste to another sheet faster?

1 Answers1