工作表赋值效率

tangdeng520

以下代码，DataArr数据量太多的话，运行非常慢，大佬是否能帮忙优化一下


Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet
Set ToSht = ThisWorkbook.Worksheets("基础数据")
ToSht.Resize(UBound(DataArr, 1), 66).Value = DataArr '需优化

ykcbf1100

代码发就发个完整的，你取片段，没法判断。

ynzsvt

数据多还想要快？代码公式都在用吧，弊病就少不了。

macrov

Application.Calculation = xlManual
   '代码放在这里
Application.Calculation = xlAutomatic

taller

ToSht.Resize(UBound(DataArr, 1), 66).Value = DataArr '需优化

这个代码有语法错误，根本没法运行，何谈优化呢

wang-way

你这第三句不报错？

tangdeng520

Sub 测厚仪数据抓取2()
   
    Application.ScreenUpdating = False
    Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet
    Dim EndRow As Long, ToSht As Worksheet, ToRng As Range
    Dim FileName As String '要合并的工作簿名称
    Dim a As Long, b As Long
    Set ToSht = ThisWorkbook.Worksheets("基础数据")
    ToSht.Rows("2:1048576").Clear '清除原有数据
   
    Dim newArr(1 To 40000, 1 To 66) As Variant
   
    jt = InputBox(请输入机台号, , 5)
    Sheets("速度分析").Cells(3, 37) = jt
    FileName = Dir(ThisWorkbook.Path & "\" & jt & "#\*.csv")
    p = 0
    Do While FileName <> ""
        Workbooks.Open FileName:=ThisWorkbook.Path & "\" & jt & "#\" & FileName
        Set DataWb = ActiveWorkbook
        Set DataSht = DataWb.Worksheets(1)
        EndRow = DataSht.Range("A1048576").End(xlUp).Row
   
        DataArr = DataSht.Range("A2").Resize(EndRow - 1, 66).Value
        Set ToRng = ToSht.Range("A1048576").End(xlUp).Offset(1, 0)
        For a = 1 To UBound(DataArr, 1) '将数组中超过15位的数字转为文本
            For b = 1 To UBound(DataArr, 2)
                If Len(DataArr(a, b)) > 15 Then
                    DataArr(a, b) = "'" & DataArr(a, b)
                End If
                newArr(a + p, b) = DataArr(a, b)
            Next b
        Next a
        p = p + EndRow - 1 '数据行数
        DataWb.Close savechanges:=False
        FileName = Dir
    Loop
   
    ToRng.Resize(UBound(newArr, 1), 66).Value = newArr
    '排序
    'Rows("1:" & EndRow).Select
    'ActiveWorkbook.Worksheets("基础数据").Sort.SortFields.Clear
    'ActiveWorkbook.Worksheets("基础数据").Sort.SortFields.Add Key:=Range("K2:K" & EndRow) _
        ', SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        'xlSortTextAsNumbers
    'With ActiveWorkbook.Worksheets("基础数据").Sort
        '.SetRange Range("A1:BN" & EndRow)
       ' .Header = xlYes
        '.MatchCase = False
       ' .Orientation = xlTopToBottom
       ' .SortMethod = xlPinYin
       ' .Apply
    'End With
   
    EndRow = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row   '计算最后一个工作表的非空行号
    Application.ScreenUpdating = True
    MsgBox "合并完成，合计" & EndRow - 1 & "条数据!"
   
End Sub

以上是完整代码，功能是提取CSV文件内容，合并到1个表中

taller

更新工作表慢的原因在于结果数组过大，你的数据可能完全不需要4W行，减少数组大小，更新工作表就会更快

Dim newArr(1 To 40000, 1 To 66) As Variant