求老师帮忙一下精简代码

王跃峰

Sub 按品位回收率汇总()
Dim ar As Variant
Sheets("品位-回收率").Cells(1, 1) = "工作表名称"
Sheets("品位-回收率").Cells(1, 2) = "班次"
Sheets("品位-回收率").Cells(1, 3) = "原矿金品位"
Sheets("品位-回收率").Cells(1, 4) = "原矿银品位"
Sheets("品位-回收率").Cells(1, 5) = "原矿铅品位"
Sheets("品位-回收率").Cells(1, 6) = "铅回收率"
Sheets("品位-回收率").Cells(1, 7) = "金回收率"
Sheets("品位-回收率").Cells(1, 8) = "银回收率"
Sheets("品位-回收率").Cells(1, 9) = "铅精矿产率"
Sheets("品位-回收率").Cells(1, 10) = "铅精矿铅品位"
Sheets("品位-回收率").Cells(1, 11) = "铅精矿金品位"
Sheets("品位-回收率").Cells(1, 12) = "铅精矿银品位"
Sheets("品位-回收率").Cells(1, 13) = "金精矿产率"
Sheets("品位-回收率").Cells(1, 14) = "金精矿金品位"
Sheets("品位-回收率").Cells(1, 15) = "金精矿银品位"
Sheets("品位-回收率").Cells(1, 16) = "金精矿铅品位"
Sheets("品位-回收率").Cells(1, 17) = "尾矿铅品位"
Sheets("品位-回收率").Cells(1, 18) = "尾矿金品位"
Sheets("品位-回收率").Cells(1, 19) = "尾矿银品位"
Dim arr()
a = InputBox("请输入品位")
ReDim arr(1 To 100000, 1 To 19)
For Each sh In Sheets
        If sh.Name <> "汇总" Then
                r = sh.Cells(Rows.Count, 2).End(xlUp).Row
                ar = sh.Range("a1:h" & r)
                For i = 7 To UBound(ar)
                        If Trim(ar(i, 2)) = "日计" Then
                                If Not IsError(ar(i, 8)) Then
                                        If ar(i, 8) > Val(a) Then
                                                n = n + 1
                                                arr(n, 1) = sh.Name
                                                arr(n, 2) = sh.Cells(i, 1)
                                                arr(n, 3) = sh.Cells(i, 8)
                                                arr(n, 4) = sh.Cells(i, 10)
                                                arr(n, 5) = sh.Cells(i, 6)
                                                arr(n, 6) = sh.Cells(i, 43)
                                                arr(n, 7) = sh.Cells(i, 44)
                                                arr(n, 8) = sh.Cells(i, 45)
                                                arr(n, 9) = sh.Cells(i, 15)
                                                arr(n, 10) = sh.Cells(i, 16)
                                                arr(n, 11) = sh.Cells(i, 18)
                                                arr(n, 12) = sh.Cells(i, 19)
                                                arr(n, 13) = sh.Cells(i, 25)
                                                arr(n, 14) = sh.Cells(i, 26)
                                                arr(n, 15) = sh.Cells(i, 27)
                                                arr(n, 16) = sh.Cells(i, 29)
                                                arr(n, 17) = sh.Cells(i, 37)
                                                arr(n, 18) = sh.Cells(i, 39)
                                                arr(n, 19) = sh.Cells(i, 40)
                                        End If
                                End If
                        End If
                Next i
        End If
Next sh
If n = "" Then MsgBox "没有符合条件的品位！": End
With Sheets("品位-回收率")
        .[a1].CurrentRegion.Offset(1) = Empty
        .[a2].Resize(n, 19) = arr
        .[a2].Resize(n, 19).Borders.LineStyle = 1
End With
MsgBox "ok!"
Sheets("品位-回收率").Activate
End Sub

王跃峰

看能不能用数组赋值

鄂龙蒙

1. Sub 按品位回收率汇总()
   
2.     Dim arr(1 To 100000, 1 To 19)
   
3.     Dim ar As Variant
   
4.     Dim a, r, i, j, n, sa, sb
   
5.     sa = Array("工作表名称", "班次", "原矿金品位", "原矿银品位", "原矿铅品位", "铅回收率", "金回收率", _
   
6.            "银回收率", "铅精矿产率", "铅精矿铅品位", "铅精矿金品位", "铅精矿银品位", "金精矿产率", "金精矿金品位", _
   
7.            "金精矿银品位", "金精矿铅品位", "尾矿铅品位", "尾矿金品位", "尾矿银品位")
   
8.     sb = Array(1, 8, 10, 6, 43, 44, 45, 15, 16, 18, 19, 25, 26, 27, 29, 37, 39, 40)
   
9.     a = InputBox("请输入品位")
   
10.     For Each sh In Sheets
    
11.         If sh.Name <> "汇总" Then
    
12.             r = sh.Cells(Rows.Count, 2).End(xlUp).Row
    
13.             ar = sh.Range("a1:h" & r)
    
14.             For i = 7 To UBound(ar)
    
15.                 If Trim(ar(i, 2)) = "日计" Then
    
16.                     If Not IsError(ar(i, 8)) Then
    
17.                         If ar(i, 8) > Val(a) Then
    
18.                             n = n + 1
    
19.                             arr(n, 1) = sh.Name
    
20.                             For j = 0 To 17
    
21.                                 arr(n, j + 2) = ar(i, sb(j))
    
22.                             Next
    
23.                         End If
    
24.                     End If
    
25.                 End If
    
26.             Next i
    
27.         End If
    
28.     Next sh
    
29.     If n = "" Then MsgBox "没有符合条件的品位！": End
    
30.     With Sheets("品位-回收率")
    
31.             .[a1].CurrentRegion.Offset(1) = Empty
    
32.             .[a1].Resize(1, 19) = sa
    
33.             .[a2].Resize(n, 19) = arr
    
34.             .[a2].Resize(n, 19).Borders.LineStyle = 1
    
35.     End With
    
36.     MsgBox "ok!"
    
37.     Sheets("品位-回收率").Activate
    
38. End Sub

复制代码

鄂龙蒙

1. Sub 按品位回收率汇总()
   
2.     Dim arr(1 To 100000, 1 To 19)
   
3.     Dim ar As Variant
   
4.     Dim a, r, i, j, n, sa, sb, sh
   
5.     sa = Array("工作表名称", "班次", "原矿金品位", "原矿银品位", "原矿铅品位", "铅回收率", "金回收率", _
   
6.            "银回收率", "铅精矿产率", "铅精矿铅品位", "铅精矿金品位", "铅精矿银品位", "金精矿产率", "金精矿金品位", _
   
7.            "金精矿银品位", "金精矿铅品位", "尾矿铅品位", "尾矿金品位", "尾矿银品位")
   
8.     sb = Array(1, 8, 10, 6, 43, 44, 45, 15, 16, 18, 19, 25, 26, 27, 29, 37, 39, 40)
   
9.     a = InputBox("请输入品位")
   
10.     For Each sh In Sheets
    
11.         If sh.Name <> "品位-回收率" And sh.Name <> "汇总" Then
    
12.             r = sh.Cells(Rows.Count, 2).End(xlUp).Row
    
13.             ar = sh.Range("a1:h" & r)
    
14.             For i = 7 To UBound(ar)
    
15.                 If Trim(ar(i, 2)) = "日计" Then
    
16.                     If Not IsError(ar(i, 8)) Then
    
17.                         If ar(i, 8) > Val(a) Then
    
18.                             n = n + 1
    
19.                             arr(n, 1) = sh.Name
    
20.                             For j = 0 To 17
    
21.                                 arr(n, j + 2) = ar(i, sb(j))
    
22.                             Next
    
23.                         End If
    
24.                     End If
    
25.                 End If
    
26.             Next i
    
27.         End If
    
28.     Next sh
    
29.     If n = "" Then MsgBox "没有符合条件的品位！": End
    
30.     With Sheets("品位-回收率")
    
31.             .[a1].CurrentRegion.Offset(1) = Empty
    
32.             .[a1].Resize(1, 19) = sa
    
33.             .[a2].Resize(n, 19) = arr
    
34.             .[a2].Resize(n, 19).Borders.LineStyle = 1
    
35.     End With
    
36.     MsgBox "ok!"
    
37.     Sheets("品位-回收率").Activate
    
38. End Sub

复制代码

3190496160

Sub 按品位回收率汇总()
Dim ar As Variant
Dim arr()
rr = Array("工作表名称", "班次", "原矿金品位", "原矿银品位", "原矿铅品位", "铅回收率", "金回收率", "银回收率", "铅精矿产率", "铅精矿铅品位", "铅精矿金品位", "铅精矿银品位", "金精矿产率", "金精矿金品位", "金精矿银品位", "金精矿铅品位", "尾矿铅品位", "尾矿金品位", "尾矿银品位")
a = InputBox("请输入品位")
Sheets("品位-回收率").Cells(1, 1).Resize(1, 19) = rr
ReDim arr(1 To 100000, 1 To 19)
For Each sh In Sheets
        If sh.Name <> "汇总" Then
                r = sh.Cells(Rows.Count, 2).End(xlUp).Row
                ar = sh.Range("a1:h" & r)
                For i = 7 To UBound(ar)
                        If Trim(ar(i, 2)) = "日计" Then
                                If Not IsError(ar(i, 8)) Then
                                        If ar(i, 8) > Val(a) Then
                                                n = n + 1
                                                arr(n, 1) = sh.Name
                                                arr(n, 2) = sh.Cells(i, 1)
                                                arr(n, 3) = sh.Cells(i, 8)
                                                arr(n, 4) = sh.Cells(i, 10)
                                                arr(n, 5) = sh.Cells(i, 6)
                                                For j = 43 To 45
                                                    arr(n, j - 37) = sh.Cells(i, j)
                                                Next j
                                                arr(n, 9) = sh.Cells(i, 15)
                                                arr(n, 10) = sh.Cells(i, 16)
                                                arr(n, 11) = sh.Cells(i, 18)
                                                arr(n, 12) = sh.Cells(i, 19)
                                                For j = 25 To 27
                                                    arr(n, j - 12) = sh.Cells(i, j)
                                                Next j
                                                arr(n, 16) = sh.Cells(i, 29)
                                                arr(n, 17) = sh.Cells(i, 37)
                                                arr(n, 18) = sh.Cells(i, 39)
                                                arr(n, 19) = sh.Cells(i, 40)
                                        End If
                                End If
                        End If
                Next i
        End If
Next sh
If n = "" Then MsgBox "没有符合条件的品位！": End
With Sheets("品位-回收率")
        .[a1].CurrentRegion.Offset(1) = Empty
        .[a2].Resize(n, 19) = arr
        .[a2].Resize(n, 19).Borders.LineStyle = 1
End With
MsgBox "ok!"
Sheets("品位-回收率").Activate
End Sub

王跃峰

王跃峰 发表于 2022-12-4 09:47
看能不能用数组赋值

不要沉底了，本人先简化一下
[a1:s1] = Split("工作表名称 班次 原矿金品位 原矿银品位 原矿铅品位 铅回收率 金回收率 银回收率 铅精矿产率 铅精矿铅品位 铅精矿金品位 铅精矿银品位 金精矿产率 金精矿金品位 金精矿银品位 金精矿铅品位 尾矿铅品位 尾矿金品位 尾矿银品位")

东亚五金

王跃峰 发表于 2022-12-4 11:11
不要沉底了，本人先简化一下
[a1:s1] = Split("工作表名称 班次 原矿金品位 原矿银品位 原矿铅品位 铅回 ...

[a1:s1] = Array("工作表名称", "班次", "原矿金品位", "原矿银品位", "原矿铅品位", "铅回收率", "金回收率", "银回收率", "铅精矿产率", "铅精矿铅品位", "铅精矿金品位", "铅精矿银品位", "金精矿产率", "金精矿金品位", "金精矿银品位", "金精矿铅品位", "尾矿铅品位", "尾矿金品位", "尾矿银品位")

王跃峰

东亚五金 发表于 2022-12-4 11:28
[a1:s1] = Array("工作表名称", "班次", "原矿金品位", "原矿银品位", "原矿铅品位", "铅回收率", "金回 ...

我先抛砖引玉关键是后面如何简化？

liulang0808

crr=array(1,8,10....)
for w=0 to ubound(crr)
arr(n,w+2)=sh.Cells(i, crr(w))
next w
其他自行调整吧

王跃峰

3190496160 发表于 2022-12-4 11:06
Sub 按品位回收率汇总()
Dim ar As Variant
Dim arr()

老师，太感谢你了