注释一行代码后，程序就变了，不能追加数据了？

gjgjgjgj · 发表于 2024-9-7 22:28

本帖最后由 gjgjgjgj 于 2024-9-7 22:29 编辑

这个代码是抄来了，改了一下，附件中，008表有按钮执行宏，每执行一次，将008表中的数据按Q列分拆到各工作表中，各表中提取的数据是008表中的指定几列数据，且每一次执行，将数据从各工作表有数据行的最后开始追加，现在需要提取的几列中，不需要E列，就注释掉，结果多次执行宏，就不能追加数据到各表中了。

分拆到表后应该是这样

现在不能追加后，第一列数据自动累加，而不是追加

arrA(rA, 5) = data(i, 3) '这行代码一注释就不能追加数据
附件中的代码，员工医疗表中已经注释掉代码了，就不能追加数据了，其它表中没有注释这行代码，就可以追加。求大神指点一下，如何修改代码，不显示这列数据了（E列），原因是什么，因为以后还要调整008表数据的放置列位置和数量，和其他分拆表指定的列数据提取，知道原因以后才能改代码？
请各位大神指点一二。谢谢，

jaxxcyh · 发表于 2024-9-8 09:31

Public Sub 发货明细表()
Dim data, wb1 As Workbook, ws As Worksheet, rngS As Range, rngE As Range, wb As Worksheet
Dim path$, dataFileName$, i&, j&, d$, k
Dim dic As New Dictionary, arrA(), arrB(), arrC(), r&, rA&, rB&, rC&, rS&, rE&, ID&
' path = ThisWorkbook.path
' dataFileName = path & "\008.xlsx"
' Set wb = Workbooks.Open(dataFileName)
' Set wb = ThisWorkbook.Worksheets("Sheet13")
Set wb = Sheets("008")
'获取数据源
With wb
Set rngS = .Range("E1").End(xlDown)
Set rngE = .Range("Q1000").End(xlUp)
data = .Range(rngS, rngE).Value
End With
ThisWorkbook.Activate
'提取页签名
For i = 2 To UBound(data)
If data(i, 5) <> "" Then
d = data(i, 13) '按13列分类页标签,-----为何莫名其妙的弄个日期格式？已删掉了 format 命令
If Not dic.Exists(d) Then dic.Add d, ""
End If
Next i
Debug.Print dic.Count
'判断页签是否存在,不存在则增加页签
For Each k In dic.Keys '页签循环
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(k) 'Set ws = ThisWorkbook.Worksheets("表名")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add(before:=ThisWorkbook.Sheets(1))
ws.Name = k
'创建表头
ws.Range("A1:W1") = Array("编号", "收案日期", "员工编号", "姓名", "性别", "身份证号", "银行卡号", "治疗性质", "发票张数", "联系电话", "交接时间", "交接明细", "就诊医院", "申请金额", "社保金额", "自费金额", "可理算金额", "赔付金额", "实赔金额", "赔付时间", "理赔周期", "通知拒赔结果时间", "备注") '写入表头
End If
Next
'提取数据存入对应页签中写入表头
Application.DisplayAlerts = False
For Each k In dic.Keys '按照字典内容逐项搜索
Debug.Print k
ReDim arrA(1 To UBound(data), 1 To 25)
ReDim arrB(1 To UBound(data), 1 To 5)
ReDim arrC(1 To UBound(data), 1 To 5)
rA = 1: rB = 1: rC = 1
For i = 1 To UBound(data) '逐个检查数据源的每一条记录，是否符合字典项
If k = data(i, 13) Then '分类列为13列
' arrA(rA, 1) = rA '编号 ------这一句要不要都无所谓，因为后面分表里的编号不是从这个数组里获取，而是程序根据记录数另外编号
arrA(rA, 3) = data(i, 1) '工号
' arrA(rA, 5) = data(i, 3) '医院等级 ------按照data(i,3)获取的是就诊日期而不是医院等级，也不应该存在arrA(rA,5)的位置，因为第5列分表里是性别列。
'------注销这列造成arrA数组第5列无数据，后面填充分表会出现数据“原地踏步”现象
arrA(rA, 8) = data(i, 2) '疾病门诊 '前面rA,8中的8是显示表中的8列，i,2中是源表中的2列
arrA(rA, 14) = data(i, 8) '申请金额
arrA(rA, 15) = data(i, 9) '社保金额
arrA(rA, 16) = data(i, 10) '自费金额
arrA(rA, 17) = data(i, 11) '可理算金额'
rA = rA + 1
End If
Next i
'如果空表则从第6行开始写入，否则追加在后面
With Sheets(k)
'E开始
r = .Range("N" & Rows.Count).End(xlUp).Row + 1 '----这一句获取分表E列的第一个空白行的行号，如果前面arrA(rA,5)注销了,那么E列为空，
'----每次循环r都是从2开始，后果就是数据“原地踏步”，不会往下延伸。
'----建议将此处的E列改为C列或N列（提倡N列，因为没有合并单元格会更好）
If .Cells(r - 1, 1).MergeCells Then
Set Rng = .Cells(r - 1, 1).MergeArea
ID = Rng(1).Value '----分表首次填充数据前，ID也就是编号为0，填完分表后，这里就是1开头的编号了。
'----如果后续多次运行程序，而数据又出现“原地踏步”的情形，每运行一次程序，这里的起始编号就会连续加1一次。
'----“原地踏步”的原因前面已经说过了，就是E列被注销，arrA里的第5列没数据造成的
'----“原地踏步”导致没一次运行程序都反复在A2单元格获取起始编号，导致累加现象。
Else
ID = .Cells(r, 1) 'ID=.Cells(r-1,1) r-1为从第4行开始显示
End If
.Range("A" & r).Resize(UBound(arrA), 25) = arrA '13 定义arrA数组列数，A为显示列也是计数列，不能改
rS = r: rE = r
For i = 2 To rA
'对员工编号连续相同的情况进行合并处理
If arrA(i, 3) = arrA(i - 1, 3) Then
rE = rE + 1
Else
If rE <> rS Then
.Range(.Cells(rS, 1), .Cells(rE, 1)).Merge '合并编号
.Range(.Cells(rS, 2), .Cells(rE, 2)).Merge '合并收案日期
.Range(.Cells(rS, 3), .Cells(rE, 3)).Merge '合并员工编号----以此类推，后面的姓名列性别列等都可合并。但合并单元格对数据处理有弊无利，不提倡！
End If
.Cells(rS, 1) = ID + 1 '填写编号（序号）列
rS = rE + 1: rE = rS: ID = ID + 1 '位置指针移动到下一条记录
End If
Next i
End With
Next k
Application.DisplayAlerts = True
Debug.Print UBound(data)
End Sub

复制代码

jaxxcyh · 发表于 2024-9-8 09:37

改代码的时候，有点感想：
1.这个代码真垃圾！
2.可以看出贴主是个初学者，对原来的代码的内在逻辑没弄清楚，随便点缝缝补补，所以出了错误也找不到原因。
3.Excel做数据处理最讨厌合并单元格，吃力还不讨好，自找麻烦，让人深恶痛绝的陋习！

jaxxcyh · 发表于 2024-9-8 09:41

Public Sub 发货明细表()
Dim data, wb1 As Workbook, ws As Worksheet, rngS As Range, rngE As Range, wb As Worksheet
Dim path$, dataFileName$, i&, j&, d$, k
Dim dic As New Dictionary, arrA(), r&, rA&, rS&, rE&, ID&
' path = ThisWorkbook.path
' dataFileName = path & "\008.xlsx"
' Set wb = Workbooks.Open(dataFileName)
' Set wb = ThisWorkbook.Worksheets("Sheet13")
Set wb = Sheets("008")
'获取数据源
With wb
Set rngS = .Range("E1").End(xlDown)
Set rngE = .Range("Q1000").End(xlUp)
data = .Range(rngS, rngE).Value
End With
ThisWorkbook.Activate
'提取页签名
For i = 2 To UBound(data)
If data(i, 5) <> "" Then
d = data(i, 13) '按13列分类页标签,-----为何莫名其妙的弄个日期格式？已删掉了 format 命令
If Not dic.Exists(d) Then dic.Add d, ""
End If
Next i
Debug.Print dic.Count
'判断页签是否存在,不存在则增加页签
For Each k In dic.Keys '页签循环
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(k) 'Set ws = ThisWorkbook.Worksheets("表名")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add(before:=ThisWorkbook.Sheets(1))
ws.Name = k
'创建表头
ws.Range("A1:W1") = Array("编号", "收案日期", "员工编号", "姓名", "性别", "身份证号", "银行卡号", "治疗性质", "发票张数", "联系电话", "交接时间", "交接明细", "就诊医院", "申请金额", "社保金额", "自费金额", "可理算金额", "赔付金额", "实赔金额", "赔付时间", "理赔周期", "通知拒赔结果时间", "备注") '写入表头
End If
Next
'提取数据存入对应页签中写入表头
Application.DisplayAlerts = False
For Each k In dic.Keys '按照字典内容逐项搜索
Debug.Print k
ReDim arrA(1 To UBound(data), 1 To 25)
rA = 1
For i = 1 To UBound(data) '逐个检查数据源的每一条记录，是否符合字典项
If k = data(i, 13) Then '分类列为13列
' arrA(rA, 1) = rA '编号 ------这一句要不要都无所谓，因为后面分表里的编号不是从这个数组里获取，而是程序根据记录数另外编号
arrA(rA, 3) = data(i, 1) '工号
' arrA(rA, 5) = data(i, 3) '医院等级 ------按照data(i,3)获取的是就诊日期而不是医院等级，也不应该存在arrA(rA,5)的位置，因为第5列分表里是性别列。
'------注销这列造成arrA数组第5列无数据，后面填充分表会出现数据“原地踏步”现象
arrA(rA, 8) = data(i, 2) '疾病门诊 '前面rA,8中的8是显示表中的8列，i,2中是源表中的2列
arrA(rA, 14) = data(i, 8) '申请金额
arrA(rA, 15) = data(i, 9) '社保金额
arrA(rA, 16) = data(i, 10) '自费金额
arrA(rA, 17) = data(i, 11) '可理算金额'
rA = rA + 1
End If
Next i
'如果空表则从第6行开始写入，否则追加在后面
With Sheets(k)
'E开始
r = .Range("N" & Rows.Count).End(xlUp).Row + 1 '----这一句获取分表E列的第一个空白行的行号，如果前面arrA(rA,5)注销了,那么E列为空，
'----每次循环r都是从2开始，后果就是数据“原地踏步”，不会往下延伸。
'----建议将此处的E列改为C列或N列（提倡N列，因为没有合并单元格会更好）
If .Cells(r - 1, 1).MergeCells Then
Set Rng = .Cells(r - 1, 1).MergeArea
ID = Rng(1).Value '----分表首次填充数据前，ID也就是编号为0，填完分表后，这里就是1开头的编号了。
'----如果后续多次运行程序，而数据又出现“原地踏步”的情形，每运行一次程序，这里的起始编号就会连续加1一次。
'----“原地踏步”的原因前面已经说过了，就是E列被注销，arrA里的第5列没数据造成的
'----“原地踏步”导致没一次运行程序都反复在A2单元格获取起始编号，导致累加现象。
Else
ID = .Cells(r, 1) 'ID=.Cells(r-1,1) r-1为从第4行开始显示
End If
.Range("A" & r).Resize(UBound(arrA), 25) = arrA '13 定义arrA数组列数，A为显示列也是计数列，不能改
rS = r: rE = r
For i = 2 To rA
'对员工编号连续相同的情况进行合并处理
If arrA(i, 3) = arrA(i - 1, 3) Then
rE = rE + 1
Else
If rE <> rS Then
.Range(.Cells(rS, 1), .Cells(rE, 1)).Merge '合并编号
.Range(.Cells(rS, 2), .Cells(rE, 2)).Merge '合并收案日期
.Range(.Cells(rS, 3), .Cells(rE, 3)).Merge '合并员工编号----以此类推，后面的姓名列性别列等都可合并。但合并单元格对数据处理有弊无利，不提倡！
End If
.Cells(rS, 1) = ID + 1 '填写编号（序号）列
rS = rE + 1: rE = rS: ID = ID + 1 '位置指针移动到下一条记录
End If
Next i
End With
Next k
Application.DisplayAlerts = True
Debug.Print UBound(data)
End Sub

复制代码

chxw68 · 发表于 2024-9-8 09:51

Sub test()
Dim r%, i%
Dim arr, brr
Dim ws As Worksheet
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("008")
r = .Cells(.Rows.Count, 5).End(xlUp).Row
arr = .Range("e3:q" & r)
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 13)) Then
Set d(arr(i, 13)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 13))(i) = Empty
Next
End With
For Each aa In d.Keys
ReDim brr(1 To d(aa).Count, 1 To 23)
m = 0
For Each bb In d(aa).Keys
m = m + 1
brr(m, 3) = arr(bb, 1)
brr(m, 8) = arr(bb, 2)
brr(m, 11) = arr(bb, 3)
brr(m, 13) = arr(bb, 4)
brr(m, 14) = arr(bb, 8)
brr(m, 15) = arr(bb, 9)
brr(m, 16) = arr(bb, 10)
brr(m, 17) = arr(bb, 11)
Next
On Error Resume Next
Set ws = Worksheets(aa)
If Err Then
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = aa
.Range("a1:w1") = Array("编号", "收案日期", "员工编号", "姓名", "性别", "身份证号", "银行卡号", "治疗性质", "发票张数", "联系电话", "交接时间", "交接明细", "就诊医院", "申请金额", "社保金额", "自费金额", "可理算金额", "赔付金额", "实赔金额", "赔付时间", "理赔周期", "通知拒赔结果时间", "备注")
End With
End If
On Error GoTo 0
With ws
r = .Cells(.Rows.Count, 3).End(xlUp).Row
.Cells(r + 1, 1).Resize(m, UBound(brr, 2)) = brr
End With
Next
End Sub

复制代码

chxw68 · 发表于 2024-9-8 09:52

楼主的代码没法修改，重新写了一段供参考。

jaxxcyh · 发表于 2024-9-8 11:51

为何发的回复迟迟不显示？要审核几个小时么？

jaxxcyh · 发表于 2024-9-8 12:14

再发一次.............

nxxhswl · 发表于 2024-9-8 14:58

chxw68 发表于 2024-9-8 09:52
楼主的代码没法修改，重新写了一段供参考。

热心的老师，每次发的都是精品。

gjgjgjgj · 发表于 2024-9-9 21:11

感谢各位大神们的无私帮助。谢谢

		自动登录	找回密码
密码			免费注册

[求助] 注释一行代码后，程序就变了，不能追加数据了？

评分