求频率

lgzxmlg

求状态出现的频率.zip (40.09 KB, 下载次数: 9)

2023-5-20 11:14 上传

点击文件名下载附件

表一中有求平均数的代码，能否修改代码，达到表二中要求的结果。

不知道为什么

如图，供参考。。。。。。。。。

lgzxmlg

不知道为什么 发表于 2023-5-20 12:25
如图，供参考。。。。。。。。。

谢谢，手机上，无法看。
Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "-")(0)): js = Val(Split(brr(i, 2), "-")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22)
.NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub

lgzxmlg

不知道为什么 发表于 2023-5-20 12:25
如图，供参考。。。。。。。。。

Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "-")(0)): js = Val(Split(brr(i, 2), "-")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22)
.NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub

lgzxmlg

不知道为什么 发表于 2023-5-20 12:25
如图，供参考。。。。。。。。。

Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "-")(0)): js = Val(Split(brr(i, 2), "-")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22)
.NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub
提示：

lgzxmlg

不知道为什么 发表于 2023-5-20 12:25
如图，供参考。。。。。。。。。

提示：对象不支持该属性或方法Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "—")(0)): js = Val(Split(brr(i, 2), "—")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22)
.NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub

feilanga

lgzxmlg 发表于 2023-5-20 15:41
提示：对象不支持该属性或方法

抄作业抄错了

lgzxmlg

feilanga 发表于 2023-5-20 15:42
抄作业抄错了

Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "—")(0)): js = Val(Split(brr(i, 2), "—")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22).NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub

lgzxmlg

feilanga 发表于 2023-5-20 15:42
抄作业抄错了

Sub zbTest()
Dim arr, brr
Dim r%, i%, j%, ks%, js%, x%, zs%, rq, t%, a&, y%
Application.Screenlpdating = False
With Sheet2
r = .Cells(.Rows.Count, 1).End(xlUp).Row - 5
arr = .Range("a6").Resize(r, 33)
r = .Cells(.Rows.Count, "aj").End(xlUp).Row - 5
.Range("al6").Resize(r, 22).ClearContents
brr = .Range("aj6").Resize(r, 24)
For i = 1 To UBound(brr)
ks = Val(Split(brr(i, 2), "—")(0)): js = Val(Split(brr(i, 2), "—")(1))
For j = 3 To 24
For x = 1 To UBound(arr)
rq = DateValue(arr(x, 1)): zs = Hour(arr(x, 1))
y = VBA.IIf(j > 14, j + 9, j)
If zs >= ks And zs < js And rq = DateValue(brr(i, 1)) Then
t = t + 1
If arr(x, y) = "A" Then a = a + 1
End If
Next x
brr(i, j) = a / t
a = 0: t = 0
Next j
Next i
With .Range("aj6").Resize(r, 24)
.Value = brrBorders.LineStyle = xlContinuous
End With
.Range("al6").Resize(r, 22)
.NumberFormatLocal = "0.0%"
End With
Application.ScreenUpdating = True
End Sub

lgzxmlg

不知道为什么 发表于 2023-5-20 12:25
如图，供参考。。。。。。。。。

请老师指教，一下午搞不出来。不知错在哪？