[已解决]代码看不明白，请解释并加注释！

zlj

 

Sub 生成通知单()
 Dim Dic As Object, ArrData, Temparr, aa$, bb
 aa = "月份水、电、管理费收费通知单"
 On Error Resume Next
    Sheets("通知单").Cells.Clear
 On Error GoTo 0
 
 Set Dic = CreateObject("scripting.dictionary")
 shn = CStr(Application.InputBox("请输入源数据工作表名称"))
 bb = Left(shn, Len(shn) - 1)
 bb = Choose(bb, "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
 Application.ScreenUpdating = 0
 If shn = False Then Exit Sub
 With Sheets(shn)
  ArrData = .Range("A3:L" & .Range("A65536").End(xlUp).Row)
  For i = 1 To UBound(ArrData)
   Dic(ArrData(i, 2)) = Dic(ArrData(i, 2)) & "," & i + 2
  Next i
 End With
 With Sheets("通知单")
  .Cells.RowHeight = 22.5
  r = 1
  For j = 1 To 12
   .Columns(j).ColumnWidth = Sheets("样表").Columns(j).ColumnWidth
  Next j
For Each tempk In Dic.keys
    Sheets("样表").Range("A1:L4").Copy
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlValues
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlPasteFormats
    .Range("A" & r) = bb & aa
    .Rows(r + 2).RowHeight = 60
    Temparr = Split(Dic(tempk), ",")
    For j = 1 To UBound(Temparr)
     .Rows(r + 2).Insert
     r = r + 1
     .Range("A" & r + 1 & ":L" & r + 1).Value _
        = Sheets(shn).Range("A" & Temparr(j) & ":L" & Temparr(j)).Value
     .Range("A" & r + 1 & ":L" & r + 1).Borders.LineStyle = 1
    Next j
    r = r + 6
Next
 End With
 aGeSet
 pr
 Application.ScreenUpdating = 1
 Sheets("样表").Activate
End Sub

T3CAcotk.rar (21.53 KB, 下载次数: 3)

2010-5-10 22:16 上传

点击文件名下载附件
代码看不明白，请解释并加注释！ 附后件

最佳答案

月排行榜 / 总排行榜

枯禅

2010-5-10 23:09

看签名

粗看了一下,大致注了一下,希望对你有帮助:

Sub 生成通知单()
 Dim Dic As Object, ArrData, Temparr, aa$, bb
 aa = "月份水、电、管理费收费通知单"
 On Error Resume Next '忽略错误
    Sheets("通知单").Cells.Clear '清除表格内容
 On Error GoTo 0 '错误跳转
 
 Set Dic = CreateObject("scripting.dictionary") '绑定字典
 shn = CStr(Application.InputBox("请输入源数据工作表名称")) '获取数据源表名
 bb = Left(shn, Len(shn) - 1)
 bb = Choose(bb, "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
 Application.ScreenUpdating = 0 '关闭屏幕刷新
 If shn = False Then Exit Sub '数据源表不存在退出
 With Sheets(shn)
  ArrData = .Range("A3:L" & .Range("A65536").End(xlUp).Row) '读取数据到数组
  For i = 1 To UBound(ArrData)
   Dic(ArrData(i, 2)) = Dic(ArrData(i, 2)) & "," & i + 2 '循环产生字典条目,主要是为了获取每个数据源所在的行号
  Next i
 End With
 With Sheets("通知单")
  .Cells.RowHeight = 22.5 '设置行高
  r = 1
  For j = 1 To 12
   .Columns(j).ColumnWidth = Sheets("样表").Columns(j).ColumnWidth '设置列宽
  Next j
For Each tempk In Dic.keys '遍历字典
    Sheets("样表").Range("A1:L4").Copy '复制样表
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlValues '选择性粘贴至目标表
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlPasteFormats
    .Range("A" & r) = bb & aa '设置表头
    .Rows(r + 2).RowHeight = 60 '设置行高
    Temparr = Split(Dic(tempk), ",") '分列字典ITEMS成数组
    For j = 1 To UBound(Temparr) '这里要的这是行号,循环一下
     .Rows(r + 2).Insert
     r = r + 1
     .Range("A" & r + 1 & ":L" & r + 1).Value _
        = Sheets(shn).Range("A" & Temparr(j) & ":L" & Temparr(j)).Value '复制相同姓名的各行数据
     .Range("A" & r + 1 & ":L" & r + 1).Borders.LineStyle = 1 '设置边框
    Next j
    r = r + 6
Next
 End With
 aGeSet
 pr
 Application.ScreenUpdating = 1
 Sheets("样表").Activate
End Sub

跳转到最佳答案楼层

枯禅

不知道哪一句看不懂?

zlj

程序整个过程讲解下。每句都要有注释。

注释完后，如果再看不明白，再请教。

谢谢！

zlj

静坐参禅为枯禅，枯禅的人佛学与武学均有极高造诣，同理枯禅的人VBA水平肯定很高。

枯禅

看签名

粗看了一下,大致注了一下,希望对你有帮助:

Sub 生成通知单()
 Dim Dic As Object, ArrData, Temparr, aa$, bb
 aa = "月份水、电、管理费收费通知单"
 On Error Resume Next '忽略错误
    Sheets("通知单").Cells.Clear '清除表格内容
 On Error GoTo 0 '错误跳转
 
 Set Dic = CreateObject("scripting.dictionary") '绑定字典
 shn = CStr(Application.InputBox("请输入源数据工作表名称")) '获取数据源表名
 bb = Left(shn, Len(shn) - 1)
 bb = Choose(bb, "一", "二", "三", "四", "五", "六", "七", "八", "九", "十", "十一", "十二")
 Application.ScreenUpdating = 0 '关闭屏幕刷新
 If shn = False Then Exit Sub '数据源表不存在退出
 With Sheets(shn)
  ArrData = .Range("A3:L" & .Range("A65536").End(xlUp).Row) '读取数据到数组
  For i = 1 To UBound(ArrData)
   Dic(ArrData(i, 2)) = Dic(ArrData(i, 2)) & "," & i + 2 '循环产生字典条目,主要是为了获取每个数据源所在的行号
  Next i
 End With
 With Sheets("通知单")
  .Cells.RowHeight = 22.5 '设置行高
  r = 1
  For j = 1 To 12
   .Columns(j).ColumnWidth = Sheets("样表").Columns(j).ColumnWidth '设置列宽
  Next j
For Each tempk In Dic.keys '遍历字典
    Sheets("样表").Range("A1:L4").Copy '复制样表
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlValues '选择性粘贴至目标表
    .Range("A" & r & ":L" & r + 3).PasteSpecial Paste:=xlPasteFormats
    .Range("A" & r) = bb & aa '设置表头
    .Rows(r + 2).RowHeight = 60 '设置行高
    Temparr = Split(Dic(tempk), ",") '分列字典ITEMS成数组
    For j = 1 To UBound(Temparr) '这里要的这是行号,循环一下
     .Rows(r + 2).Insert
     r = r + 1
     .Range("A" & r + 1 & ":L" & r + 1).Value _
        = Sheets(shn).Range("A" & Temparr(j) & ":L" & Temparr(j)).Value '复制相同姓名的各行数据
     .Range("A" & r + 1 & ":L" & r + 1).Borders.LineStyle = 1 '设置边框
    Next j
    r = r + 6
Next
 End With
 aGeSet
 pr
 Application.ScreenUpdating = 1
 Sheets("样表").Activate
End Sub

枯禅

按F8逐步执行比看我上面的强多了