导入数据加速求助

lt6071

请大佬看看下面程序，能否优化一下，从（YHGC20230342024.3.20 HXL V1）中的品号汇总表点击导入数据（新编码规则物料表2024.3.27.xlsm）导入数据时间太长。
下面是导入数据的VBA程序
Private Sub CommandButton1_Click()

    Dim dict As String
    Dim file As String
    Dim filename As String
    Dim name As String
    Dim Sht As Excel.Worksheet

    Dim dataExcel, Workbook, Sheet
    Dim totalRow As Integer
    Dim totalColumn
    Dim i%, j%, MaxRow%
    'Dim Arr1
    Dim a()
    Dim Sss

    On Error Resume Next

    dict = Me.Range("L2").Value
    file = Me.Range("L3").Value
    filename = dict & "\" & file

    'Workbooks.Open "'" & filename & "'"
    name = "'" & filename & "'!汇总"

    'Application.Run name    'Application.Run "abc.xlsm!Sheet1.

    Set dataExcel = CreateObject("Excel.Application")
    Set Workbook = dataExcel.Workbooks.Open(dict & "\" & file)
    Set Sheet = Workbook.Worksheets("总表") '读取第一个sheet页的数据


    'Arr1 = Sheet.UsedRange
    MaxRow = Sheet.Range("C3").End(xlDown).Row
    Sss = Sheet.Range("A3:L" & MaxRow)

    Workbook.Close

    Sheets("品号汇总表").Active
    'Application.ScreenUpdating = False
    For i = 1 To MaxRow - 2

        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 1) = Sss(i, 1) '序号
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 2) = Sss(i, 2) '品号
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 3) = Sss(i, 3) '物料名称’
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 4) = Sss(i, 4) '规格型号’
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 5) = Sss(i, 5) '单位
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 6) = Sss(i, 6) '申请人
        'Sheets("品号汇总表").Cells(i + 4,7) = arr(3, 1)   '厂商名称
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 8) = Sss(i, 8)    '备注
        ActiveWorkbook.Sheets("品号汇总表").Cells(i + 4, 9) = Sss(i, 9)   '其他

    Next i
    'Application.ScreenUpdating = True

    MsgBox "读取成功！", vbSystemModal, "导入数据" & name '读取完后弹框提醒
    ActiveWindow.ScrollRow = 1
    Application.StatusBar = "更新时间: " & Date & Time




End Sub

3190496160

目前的代码直接频繁操作单元格写入数据，速度肯定慢，可以用先把数据赋值给数组，然后一次性写入单元格

shiruiqiang

不要反复操作单元格

hongshan2019

换数组。单元格咔咔咔

清风竹-

请看附件。

lt6071

清风竹- 发表于 2024-3-27 12:09
请看附件。

感谢大佬帮助@

ykcbf1100

AI写的代码还是少用，直接操作单元格肯定慢，换数组会快很多。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.27
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("品号汇总表")
   
4.     p = ThisWorkbook.Path
   
5.     With Application.FileDialog(msoFileDialogFilePicker)
   
6.         .InitialFileName = p
   
7.         .Title = "请选择对应Excel文件"
   
8.         .AllowMultiSelect = False
   
9.         .Filters.Clear
   
10.         .Filters.Add "Excel文件", "*.xls*"
    
11.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
12.     End With
    
13.     Set wb = Workbooks.Open(f, 0)
    
14.     With wb.Sheets("总表")
    
15.         r = .Cells(Rows.Count, 1).End(3).Row
    
16.         arr = .[a3].Resize(r - 2, 9)
    
17.         wb.Close False
    
18.     End With
    
19.     With sh
    
20.         .UsedRange.Offset(4).ClearContents
    
21.         .[a5].Resize(UBound(arr), UBound(arr, 2)) = arr
    
22.         .[a5].Resize(UBound(arr), UBound(arr, 2)).Borders.LineStyle = 1
    
23.     End With
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    
27. 
    

复制代码

lt6071

ykcbf1100 发表于 2024-3-27 14:52
参与一下。。。

厉害，都是大神级别，膜拜了！