|
请高手指点完善代码
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False '关闭屏幕刷新
Range("j2:j20,n2:n20,r2:r20,v2:v20,z2:z20,ad2:ad20,ah2:ah20").Select
Selection.ClearContents '清除数据
Dim u As Long
Dim sl, je, ksl, jje, slz, sly As Variant
je = Array("i", " m", "q", "u", "y", "ac", "ag")
sl = Array("h", "l", "p", "t", "x", "ab", "af")
ksl = Array("j", "n", "r", "v", "z", "ad", "ah")
jje = Array(9, 13, 17, 21, 25, 29, 33)
slz = Array(10, 14, 18, 22, 26, 30, 34)
sly = Array(8, 12, 16, 20, 24, 28, 32)
For n = 0 To 6
u = Application.WorksheetFunction.Sum(Range(je(n) & "2" & ":" & je(n) & "20"))
If u < 103000 Then
Range(sl(n) & "2" & ":" & sl(n) & "20").Copy
Range(ksl(n) & "2").PasteSpecial xlPasteValues
Else
For i = 1 To 20
p = p + Cells(i + 1, jje(n)) '累加
Debug.Print "p=" & p
If p >= 103000 Then '加到大于等于指定值是停止
Exit For
End If
x = i + 2 '范围的终点
Next
Range("d21") = x
s = Application.WorksheetFunction.Max(Range(Cells(2, jje(n)), Cells(x, jje(n)))) '范围内最大值
Range("c21").Value = s
For Each Rng In Range(je(n) & "2" & ":" & je(n) & "20") '求最大值的行号
If Rng = s Then
a = Rng.Row
Range("b21") = a
End If
Next
Range(sl(n) & "2" & ":" & sl(n) & x).Copy
Range(ksl(n) & "2").PasteSpecial xlPasteValues
m = Int((p - 103000) / Range("c" & a)) + 1
Cells(a, slz(n)) = Cells(a, sly(n)) - m
End If
Next
Range("a25:e55").Select
Selection.ClearContents
For i = 2 To 20
If Cells(i, 5) <> 0 Then
Union(Cells(i, 1), Cells(i, 6)).Copy
Range("a65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Union(Cells(i, 3), Cells(i, 7)).Copy
Range("c65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(i, 5).Copy
Range("e65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next
arr = Array(10, 14, 18, 22)
For i = 0 To UBound(arr)
For u = 2 To 20
If Cells(u, arr(i)) <> 0 Then
Cells(u, arr(i)).Copy
Range("b65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(u, 1).Copy
Range("a65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(u, 3).Copy
Range("c65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(u, arr(i) + 1).Copy
Range("d65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next
Next
Application.ScreenUpdating = True
End Sub
|
|