代码执行不了

雷雷爸

哪位大师能帮我看下模块里的代码为什么执行不了呢

shiruiqiang

1、建议不要反复操作单元格，数据量一大就卡。2，代码思路看不懂
Sub FillData()
Dim x, m, n, j
Dim arr, brr(1 To 4000, 1 To 8)
Dim starday, endday, qd

Dim sht As Worksheet

For Each sht In Sheets
sht.Unprotect ("123456")'密码
Next


starday = Sheets("抗压强度评定").[o3]
endday = Sheets("抗压强度评定").[o4]
qd = Sheets("抗压强度评定").[p4]
arr = Sheets("试块强度输入").[a1].CurrentRegion
For x = 2 To UBound(arr)
If CDate(arr(x, 2)) >= CDate(starday) And CDate(arr(x, 2)) <= CDate(endday) Then
If arr(x, 11) = qd Then
If arr(x, 9) <> "" Then
n = n + 1
If n Mod 8 = 0 Then
j = (n \ 8)
m = 8
Else
j = (n \ 8) + 1
m = n Mod 8
End If
brr(j, m) = arr(x, 8)
End If
End If
End If
Next


Sheets("抗压强度评定").[e5:l35].ClearContents
If n > 0 And n <= 248 Then
Sheets("抗压强度评定").[e5].Resize(j, 8) = brr
Else
MsgBox "提取到的数据共:" & n & "个;超过248个数量!"
GoTo 100:
Exit Sub
End If

100:
For Each sht In Sheets
sht.Protect ("123456")
Next


End Sub

雷雷爸

shiruiqiang 发表于 2023-6-4 11:47
1、建议不要反复操作单元格，数据量一大就卡。2，代码思路看不懂
Sub FillData()
Dim x, m, n, j

麻烦老师能不能帮我加个工作表保护的代码，因为这两个工作中还有很多函数，不加保护，担心有时候函数会被误删了

shiruiqiang

楼上修改了，等审核。或者照截图自己抄一下

雷雷爸

shiruiqiang 发表于 2023-6-4 15:54
楼上修改了，等审核。或者照截图自己抄一下

老师,工作簿里还有其他工作表，并且有自动更新的图片，一旦所有工作表循环加密撤销保护的话，更新图片的工作表会报错，因为工作表加密里面的编辑对象勾选就被取消了，能不能只对这两个工作表进行循环保护，

shiruiqiang

雷雷爸 发表于 2023-6-4 18:25
老师,工作簿里还有其他工作表，并且有自动更新的图片，一旦所有工作表循环加密撤销保护的话，更新图片的 ...

Sub FillData()
Dim x, m, n, j
Dim arr, brr(1 To 4000, 1 To 8)
Dim starday, endday, qd


Sheets("抗压强度评定").Unprotect ("123456")'密码
Sheets("试块强度输入").Unprotect ("123456")'密码


starday = Sheets("抗压强度评定").[o3]
endday = Sheets("抗压强度评定").[o4]
qd = Sheets("抗压强度评定").[p4]
arr = Sheets("试块强度输入").[a1].CurrentRegion
For x = 2 To UBound(arr)
If CDate(arr(x, 2)) >= CDate(starday) And CDate(arr(x, 2)) <= CDate(endday) Then
If arr(x, 11) = qd Then
If arr(x, 9) <> "" Then
n = n + 1
If n Mod 8 = 0 Then
j = (n \ 8)
m = 8
Else
j = (n \ 8) + 1
m = n Mod 8
End If
brr(j, m) = arr(x, 8)
End If
End If
End If
Next


Sheets("抗压强度评定").[e5:l35].ClearContents
If n > 0 And n <= 248 Then
Sheets("抗压强度评定").[e5].Resize(j, 8) = brr
Else
MsgBox "提取到的数据共:" & n & "个;超过248个数量!"
GoTo 100:
Exit Sub
End If

100:
Sheets("抗压强度评定").Protect ("123456")'密码
Sheets("试块强度输入").Protect ("123456")'密码

End Sub

雷雷爸

shiruiqiang 发表于 2023-6-4 19:36
Sub FillData()
Dim x, m, n, j
Dim arr, brr(1 To 4000, 1 To 8)

非常感谢老师，麻烦您这么多次，这次终于完美解决了