运行错误九，下标越界如何办

少如

quqiyuan 发表于 2024-9-9 17:23
修改一下，改用数组，。。。

非常好，谢谢老师！
为让这个表更完美一些，我想将下面 “审核” 等兰色字的字段一同复制到【记录明细】表中的Y至AE列
我自己搞了一晚上，没成功，点【录入数据】按扭没有任何动作，只能再让老师辛苦辛苦再帮忙作一下。
移植 - 5稿.zip (65.89 KB, 下载次数: 5)

2024-9-9 20:20 上传

点击文件名下载附件

chxw68

修改好了。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub DYBC()
Dim arr, brr
Dim r, k, x, y, i&, j&
With Worksheets("录入界面")
     arr = .Range("a1", .UsedRange)
     s = Application.CountA(.Range("a16:a34"))
     .PageSetup.PrintArea = "$A$2:$L$57"
End With
If s = 0 Then Exit Sub
With Worksheets("记录明细")
     r = .Range("a65536").End(xlUp).Row
     If r <= 1 Then k = 0 Else k = .Range("a" & r)
     ReDim brr(1 To s, 1 To 31)
     For x = 1 To s
         k = k + 1
         brr(x, 1) = k            '序号
         brr(x, 2) = arr(11, 12)  '开具日期，第11行笫12列
         brr(x, 3) = arr(10, 2)   '姓名
         brr(x, 4) = arr(11, 2)   '民族
         brr(x, 5) = arr(12, 2)   '初步诊断
         brr(x, 6) = arr(10, 4)   '性别
         brr(x, 7) = arr(11, 4)   '科室
         brr(x, 8) = arr(12, 4)   '电话
         brr(x, 9) = arr(10, 10)  '年龄
         brr(x, 10) = arr(11, 10)  '病例编号
         brr(x, 11) = arr(12, 10)  '地址
         brr(x, 12) = arr(10, 12)  '参保类型
         brr(x, 25) = arr(35, 2)
         brr(x, 26) = arr(36, 2)
         brr(x, 27) = arr(36, 4)
         brr(x, 28) = arr(36, 6)
         brr(x, 29) = arr(36, 8)
         brr(x, 30) = arr(36, 10)
         brr(x, 31) = arr(36, 12)
         For j = 13 To 24
             brr(x, j) = arr(x + 15, j - 12)
         Next j
     Next
     .Range("a" & r + 1).Resize(UBound(brr), 31) = brr
End With
If MsgBox("亲，要打印该合同吗？", vbYesNo, "提示") = vbNo Then
   MsgBox ("亲，合同数据已保存")
   Exit Sub
Else
   Worksheets("录入界面").PrintPreview '.PrintOut
End If
End Sub

少如

quqiyuan 发表于 2024-9-9 21:51
参与一下，仅供参考。。。

老师可能传错附件了，好象没有任何变化呢？老师辛苦！

少如

chxw68 发表于 2024-9-9 21:04
修改好了。

非常感谢老师出手相助，谢谢！谢谢！
您多次帮助学生解决难题，您辛苦了！！！