Чрезвычайно медленное перемещение данных VBA - Альтернативы

Question

У меня есть этот рабочий код, который копирует данные из определенных столбцов в новый файл.

Sub GetFileCopyData()
   Dim Fname As String
   Dim SrcWbk As Workbook
   Dim DestWbk As Workbook

   Set DestWbk = ThisWorkbook

   Application.Calculation = xlManual
   Application.ScreenUpdating = False

   Sheets("Data").UsedRange.ClearContents

   Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.csv*), *.csv*", Title:="Select a File")
   If Fname = "False" Then Exit Sub
   Set SrcWbk = Workbooks.Open(Fname)

   SrcWbk.Sheets(1).Range("A:A").Copy DestWbk.Sheets("Data").Range("A:A")
   SrcWbk.Sheets(1).Range("E:E").Copy DestWbk.Sheets("Data").Range("B:B")
   SrcWbk.Sheets(1).Range("M:M").Copy DestWbk.Sheets("Data").Range("C:C")
   SrcWbk.Sheets(1).Range("AD:AD").Copy DestWbk.Sheets("Data").Range("D:D")
   SrcWbk.Sheets(1).Range("AF:AF").Copy DestWbk.Sheets("Data").Range("E:E")
   SrcWbk.Sheets(1).Range("DA:DA").Copy DestWbk.Sheets("Data").Range("F:F")
   SrcWbk.Sheets(1).Range("AEG:AEG").Copy DestWbk.Sheets("Data").Range("G:G")
   SrcWbk.Sheets(1).Range("AEM:AEM").Copy DestWbk.Sheets("Data").Range("H:H")

   SrcWbk.Close False

   Application.ScreenUpdating = True
   Application.Calculation = xlAutomatic

End Sub

Это работает очень медленно. Я уже пытался отключить обновление экрана и т. Д. Я прочитал, что следующее выполняется быстрее, чем копирование, что медленно.

Range("A1:Z100").value = Range("A101:Z200").value

Может кто-нибудь сказать, пожалуйста, как это реализовать? Я пытался использовать этот код, но он оказался пустым:

SrcWbk.Sheets(1).Range("A:A").Value = DestWbk.Sheets("Data").Range("A:A").Value

Answer 1

Похоже, ваше требование - просто извлечь определенные столбцы из файла CSV, тогда Get & Transform должно быть наилучшим решением, а не VBA-решением.

Еще один вариант - использовать MicrosoftТекстовый драйвер через ADO в VBA.

Answer 2

Если все, что вы копируете, это значения, а не копирование всего столбца, что требует очень много ресурсов (фактически вы копируете 1048576 ячеек), вы можете попробовать реализовать оператор lastrow и скопировать только используемый диапазон столбца. Это может значительно сократить время выполнения в зависимости от того, сколько у вас значений. Что-то из строк:

Sub copy()
Dim lastr As Long
lastr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Sheet2.Range("A1:A" & lastr).Value = Sheet1.Range("A1:A" & lastr).Value
End Sub

Чтобы адаптировать ваш код, вы должны заменить следующую строку:

SrcWbk.Sheets(1).Range("A:A").Copy DestWbk.Sheets("Data").Range("A:A")

на:

lastr = SrcWbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
DestWbk.Sheets("Data").Range("A" & lastr).value = SrcWbk.Sheets(1).Range("A" & lastr).value

Обратите внимание, еслиДлина вашего столбца варьируется, вы должны повторить последний расчет для каждого столбца. Если все ваши столбцы имеют одинаковую длину (все заканчиваются в одной строке), тогда подойдет первое вычисление для каждого столбца.