EXCEL VBA для обработки больших объемов данных, как быстрее фильтровать данные и копировать вставки на другой лист?

Question

У меня есть файл CVS с объемом данных более ста тысяч. Поскольку в файле данных много нерегулярного пространства, я использовал фильтр «пространство» для фильтрации по одному столбцу. После фильтрации я копирую этот столбец и вставляю на другой лист. Я делаю эти шаги до конца данных столбца. В моем файле много столбцов и сотни тысяч строк, но после фильтра «пробел» это около 100 тысяч. Но теперь у меня возникла проблема, мне пришлось ждать около 5 минут слишком долго, чтобы закончить эту работу. Как я мог бежать быстрее? Я пытаюсь использовать Selection.SpecialCells(xlCellTypeVisible).Copy, заняло больше времени. Спасибо!

Ниже мое excel VBA пространство фильтра и скопируйте код вставки

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

Answer 1

Не могу четко понять, как вы хотите фильтровать «пробел».Предположение (из кода), что цель состоит в том, чтобы отфильтровать любые строки, содержащие пробел или пробел, я хотел бы сделать это непосредственно для чтения и записи в текстовый файл.

Более того, если предположение верно, команды Select, Активировать и т. Д. В течение кода увеличить время работы.Также хорошо работать в цикле для каждого столбца, но думаю, что метод диапазона объединения не нужен.После применения фильтра ко всем столбцам можно скопировать и вставить всю область данных.Но это также может увеличить вероятность ошибки 1004. «MS Excel не может создать или использовать ссылку на диапазон данных, потому что она слишком сложна», так как здесь данные, с которыми приходится иметь дело, превышают 100 К.

Поэтому я попытался сданные более 150 тыс. строк и 50 столбцов напрямую. Требуется 20 с лишним секунд, чтобы обработать данные как текстовый файл, и еще 20 с, чтобы открыть полученный файл CSV и сохранить его как xlsx.Формат файла, используемый в коде, создает некоторую проблему (по крайней мере, в Excel 2007), поэтому я сохранил его как 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

Поскольку я лично не предпочитаю вести вычисления, обработку событий иобновление экрана выключено (в обычных случаях) я не добавил эти стандартные строки.Однако вы можете использовать эти стандартные методы по своему усмотрению.