初学编写宏代码：请教如何提升宏代码运行速度？

gzclc

初学编写宏代码：想从《数据库》读取D列编号的不规律数据，遇数据较多时，以下代码运行速度很慢，请教大神如何优化？


Sub dj()
    Application.ScreenUpdating = False
   
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim dataRange As Range
    Dim sourceData As Variant
    Dim i As Long
    Dim j As Long
   
    Set ws1 = Sheet1
    Set ws2 = Sheet2
   
    lastRow1 = ws1.Cells(ws1.Rows.Count, 4).End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
   
   
    Set dataRange = ws2.Range("A1:AW" & lastRow2)
    sourceData = dataRange.Value
   
    For i = 4 To lastRow1
        For j = 2 To lastRow2
            
            If ws1.Cells(i, 4).Value = sourceData(j, 1) Then
               
                With ws1.Rows(i)
                    .Cells(1).Value = i - 6 + 1
                    .Cells(2).Value = sourceData(j, 2)
                    .Cells(3).Value = sourceData(j, 4)
                    .Cells(6).Value = sourceData(j, 5)
                    .Cells(7).Value = sourceData(j, 8)
                    .Cells(8).Value = sourceData(j, 9)
                    .Cells(9).Value = sourceData(j, 12)
                    .Cells(10).Value = sourceData(j, 13)
                    .Cells(11).Value = sourceData(j, 21)
                    .Cells(12).Value = sourceData(j, 23)
                    .Cells(13).Value = sourceData(j, 26)
                    .Cells(14).Value = sourceData(j, 45)
                End With
                Exit For
            End If
        Next j
    Next i
   

    Application.ScreenUpdating = True
End Sub

taller

双重循环，数据多就会慢，使用ADO SQL提速

1. Option Explicit
   
2. 
   
3. Sub SqlQuery()
   
4.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
5.     Set conn = CreateObject("ADODB.Connection")
   
6.     Set rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName
   
8.     Select Case Application.Version * 1
   
9.     Case Is <= 11
   
10.         conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
    
11.     Case Is >= 12
    
12.         conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
13.     End Select
    
14.     Dim dataRng As Range
    
15.     With Sheets("汇总").Range("A5").CurrentRegion
    
16.         Set dataRng = Sheets("汇总").Range("A5", .Cells(.Cells.Count))
    
17.     End With
    
18.     strSQL = "SELECT a.序号,b.故障描述,b.故障类型,b.工单号,a.[F5],b.工单来源,b.工单状态,b.客户名称,b.联系电话,b.联系地址,b.报修时间,b.指派时间,b.回执时间,b.维修完成图片 from [汇总$" & dataRng.Address(0, 0) & "] as a left outer join [数据库$] as b on a.工单号=b.工单号 order by a.序号"
    
19.     rst.Open strSQL, conn, 1, 1
    
20.     Sheets("汇总").Range("a6").CopyFromRecordset rst
    
21.     rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
22. End Sub
    

复制代码

taller

shiruiqiang

还可以：1、数组双循环
2，表2工单号：字典(工单号)=j

3190496160

Sub dj()
Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim r As Long
Dim rs As Long
Dim ar As Variant, br As Variant
Dim i As Long
Dim s As Long
Set ws1 = Sheet1
Set ws2 = Sheet2
r = ws1.Cells(ws1.Rows.Count, 4).End(xlUp).Row
rs = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
ar = ws2.Range("a1:aw" & rs)
br = ws1.Range("a5:n" & r)
For i = 2 To UBound(br)
    For s = 2 To UBound(ar)
        If br(i, 4) = ar(s, 1) Then
            br(i, 1) = i - 1
            br(i, 2) = ar(s, 2)
            br(i, 3) = ar(s, 4)
            br(i, 6) = ar(s, 5)
            br(i, 7) = ar(s, 8)
            br(i, 8) = ar(s, 9)
            br(i, 9) = ar(s, 12)
            br(i, 10) = ar(s, 13)
            br(i, 11) = ar(s, 21)
            br(i, 12) = ar(s, 23)
            br(i, 13) = ar(s, 26)
            br(i, 14) = ar(s, 45)
            Exit For
        End If
    Next s
Next i
ws1.Range("a5:n" & r) = br
Application.ScreenUpdating = True
End Sub

3190496160

读取数据.rar (1.74 MB, 下载次数: 6)

2024-3-22 08:24 上传

点击文件名下载附件

ykcbf1100

用数组啊，你直接对单元格操作，数据一多，速度肯定下来了。

xbox1210

参与一下。

ykcbf1100

楼主的代码明显是AI写的。

用字典+数组新写一个，速度应该快很多了。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.22
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     b = [{2,3,6,7,8,9,10,11,12,13,14}]
   
5.     With Sheets("汇总")
   
6.         c = .UsedRange.Columns.Count
   
7.         brr = .[a5].Resize(1, c)
   
8.     End With
   
9.     For j = 2 To UBound(brr, 2)
   
10.         s = brr(1, j)
    
11.         If s <> Empty Then d1(s) = j
    
12.     Next
    
13.     With Sheets("数据库")
    
14.         r = .Cells(Rows.Count, 1).End(3).Row
    
15.         c = .UsedRange.Columns.Count
    
16.         arr = .[a1].Resize(r, c)
    
17.     End With
    
18.     For i = 2 To UBound(arr)
    
19.         s = arr(i, 1)
    
20.         d(s) = i
    
21.     Next
    
22.     On Error Resume Next
    
23.     With Sheets("汇总")
    
24.         r = .Cells(Rows.Count, 1).End(3).Row
    
25.         c = .UsedRange.Columns.Count
    
26.         brr = .[a1].Resize(r, c)
    
27.         For i = 6 To UBound(brr)
    
28.             s = brr(i, 4)
    
29.             If d.exists(s) Then
    
30.                 For j = 2 To UBound(b)
    
31.                     brr(i, b(j)) = arr(d(s), d1(brr(5, j)))
    
32.                 Next
    
33.             End If
    
34.         Next
    
35.         .[a1].Resize(r, c) = brr
    
36.     End With
    
37.     MsgBox "OK！"
    
38. End Sub
    

复制代码