求老师帮忙一下精简代码

王跃峰

鄂龙蒙 发表于 2022-12-4 11:00

帮忙看一下arr(n, j + 2) = ar(i, sb(j))下标越界

王跃峰

鄂龙蒙 发表于 2022-12-4 11:03

提示arr(n, j + 2) = ar(i, sb(j))下标越界

王跃峰

liulang0808 发表于 2022-12-4 11:41
crr=array(1,8,10....)
for w=0 to ubound(crr)
arr(n,w+2)=sh.Cells(i, crr(w))

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
                                                crr = Array(1, 8, 10, 6, 43, 44, 45, 15, 16, 18, 19, 25, 26, 27, 29, 37, 39, 40)
For w = 0 To UBound(crr)
arr(n, w + 2) = sh.Cells(i, crr(w))
Next w
                                        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
工作表名称这一列没有数据

王跃峰

liulang0808 发表于 2022-12-4 11:41
crr=array(1,8,10....)
for w=0 to ubound(crr)
arr(n,w+2)=sh.Cells(i, crr(w))

自己搞错了，太感谢你了

王跃峰

liulang0808 发表于 2022-12-4 11:41
crr=array(1,8,10....)
for w=0 to ubound(crr)
arr(n,w+2)=sh.Cells(i, crr(w))

今天没分了，明天一定补上

王跃峰

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
                                                crr = Array(1, 8, 10, 6, 43, 44, 45, 15, 16, 18, 19, 25, 26, 27, 29, 37, 39, 40)
For w = 0 To UBound(crr)
arr(n, w + 2) = sh.Cells(i, crr(w))
Next w
                                        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 14:40
提示arr(n, j + 2) = ar(i, sb(j))下标越界

j+2   相当于2--19   您自己看一下实际列数呀