求助优化一下代码

weixing1209

Sub 执行2024年()
    Sheets("2024年").[B3:EZ3000].ClearContents
    Dim i As Integer
    Dim lastRow As Long
    Dim ws As Worksheet
    Set ws = Sheets("2024年")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    For i = 1 To 31
        With ws.Range(ws.Cells(3, 2 + i - 1), ws.Cells(lastRow, 2 + i - 1))
            .Formula = "=IFERROR(VLOOKUP(A3,'" & Format(i, "00") & "'!A:CH,34,0) & CHAR(10) & """", ""0"")"
            .Offset(0, 32).Formula = "=IFERROR(VLOOKUP(A3,'" & Format(i, "00") & "'!A:CH,50,0) & CHAR(10) & """", ""0"")"
            .Offset(0, 64).Formula = "=IFERROR(VLOOKUP(A3,'" & Format(i, "00") & "'!A:CH,51,0) & CHAR(10) & """", ""0"")"
            .Offset(0, 96).Formula = "=IFERROR(VLOOKUP(A3,'" & Format(i, "00") & "'!A:CH,32,0) & CHAR(10) & """", ""0"")"
            End With
    Next i
End Sub

2024工作表中如何A列编号增加，执行后会很卡，求帮优化一个代码且执行速度快。

gwjkkkkk

感觉速度还好。。。

shiruiqiang

字典嵌套一下

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.10
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("2024年")
   
6.     p = ThisWorkbook.Path & ""
   
7.     For Each sht In Sheets
   
8.         If sht.Name <> sh.Name Then
   
9.             With sht
   
10.                 r = .Cells(Rows.Count, 1).End(3).Row
    
11.                 arr = .Range("a1:ay" & r)
    
12.                 For i = 4 To UBound(arr)
    
13.                     s = arr(i, 1) & "|" & .Name
    
14.                     d(s) = Array(arr(i, 34), arr(i, 50), Val(arr(i, 51)), arr(i, 32))
    
15.                 Next
    
16.             End With
    
17.         End If
    
18.     Next
    
19.     t = d.items
    
20.     With sh
    
21.         .[b3:dz1000].ClearContents
    
22.         arr = .UsedRange
    
23.         For i = 3 To UBound(arr)
    
24.             n = 0
    
25.             For j = 2 To UBound(arr, 2) Step 32
    
26.                 n = n + 1
    
27.                 For x = 1 To 31
    
28.                     s = arr(i, 1) & "|" & arr(2, j + x - 1)
    
29.                     If d.exists(s) Then
    
30.                         arr(i, j + x - 1) = d(s)(n - 1)
    
31.                     End If
    
32.                 Next
    
33.             Next
    
34.         Next
    
35.         .Columns(1).NumberFormatLocal = "@"
    
36.         .UsedRange = arr
    
37.         .UsedRange.EntireColumn.AutoFit
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

weixing1209

ykcbf1100 发表于 2024-2-10 19:03
附件供参考。。。

麻烦再修改一下代码，现在01-31工作表不是从A列开始，变成B列，我修改一些代码，但执行是空白数据，麻烦再修改一下。

ykcbf1100

weixing1209 发表于 2024-2-18 21:58
麻烦再修改一下代码，现在01-31工作表不是从A列开始，变成B列，我修改一些代码，但执行是空白数据，麻烦 ...

改好了。。。
上次的代码没有特别精细，我发现你有好多表不是需要的表，还有很多空表，所以，你直接改原代码并不能肯定成功。

ykcbf1100

新代码供参考。。。

1. Sub ykcbf()  '//2024.2.19
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("2024年")
   
6.     p = ThisWorkbook.Path & ""
   
7.     On Error Resume Next
   
8.     For Each sht In Sheets
   
9.         If Val(sht.Name) Then
   
10.             If IsArray(sht.UsedRange) Then
    
11.                 With sht
    
12.                     r = .Cells(Rows.Count, 1).End(3).Row
    
13.                     c1 = .Rows(3).Find("扫码笔数", , , , , 1).Column
    
14.                     c2 = .Rows(3).Find("支付笔数", , , , , 1).Column
    
15.                     c3 = .Rows(3).Find("支付金额", , , , , 1).Column
    
16.                     c4 = .Rows(3).Find("库存合计", , , , , 1).Column
    
17.                     arr = .[a1].Resize(r, c3)
    
18.                     For i = 4 To UBound(arr)
    
19.                         s = arr(i, 2) & "|" & .Name
    
20.                         d(s) = Array(arr(i, c1), arr(i, c2), Val(arr(i, c3)), arr(i, c4))
    
21.                     Next
    
22.                 End With
    
23.             End If
    
24.         End If
    
25.     Next
    
26.     With sh
    
27.         .UsedRange.Offset(2, 1) = ""
    
28.         arr = .UsedRange
    
29.         For i = 3 To UBound(arr)
    
30.             n = 0
    
31.             For j = 2 To UBound(arr, 2) Step 32
    
32.                 n = n + 1
    
33.                 For x = 1 To 31
    
34.                     s = arr(i, 1) & "|" & arr(2, j + x - 1)
    
35.                     If d.exists(s) Then
    
36.                         arr(i, j + x - 1) = d(s)(n - 1)
    
37.                     End If
    
38.                 Next
    
39.             Next
    
40.         Next
    
41.         .Columns(1).NumberFormatLocal = "@"
    
42.         .UsedRange = arr
    
43.         .UsedRange.EntireColumn.AutoFit
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46. End Sub

复制代码