Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2970|回复: 8

[已解决]改写VBA代码

[复制链接]
发表于 2017-5-22 10:03 | 显示全部楼层 |阅读模式
本帖最后由 guo_zhan11 于 2017-5-22 21:59 编辑

请高手帮我改写这个代码,在VBA中什么位置加入ss = ss & "、" & arr(i, 8),能在句子之间加入“、”号?

Sub 打印()
    Dim arr, brr(), crr(1 To 4, 1 To 18), d, K, i%, j%, q, Y, n, a, ss
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet2.Range("A3").CurrentRegion
        For i = 4 To UBound(arr)
           If arr(i, 12) <> "" Then d(arr(i, 5) & "+" & arr(i, 14)) = ""
        Next i
    K = d.keys
    a = Sheet1.Range("V3")
        For j = 0 To UBound(K)
            n = 0: ss = ""
            For i = 4 To UBound(arr)
                ReDim Preserve brr(1 To UBound(arr), 1 To 19)
                If arr(i, 1) <> "" And arr(i, 5) & "+" & arr(i, 14) = a Then
                    n = n + 1
                    brr(n, 1) = arr(i, 1)
                    brr(n, 2) = arr(i, 2)
                    brr(n, 3) = arr(i, 3)
                    brr(n, 4) = arr(i, 4)
                    brr(n, 5) = arr(i, 6) & "--" & arr(i, 7)
                    brr(n, 10) = arr(i, 9)
                    brr(n, 13) = arr(i, 10)
                    brr(n, 16) = arr(i, 11)
                    brr(n, 18) = arr(i, 12)
                    brr(n, 19) = arr(i, 8)
                End If
            Next i
        Next j
        Y = Application.RoundUp(n / 4, 0)
        For q = 1 To Y
            With Sheet1
                .Range("H3:J3,F5,I5:S5,B8:S11") = ""
                .Range("F5") = Split(a, "+")(0)
                .Range("H3") = Split(a, "+")(1)
                ss = ""
                    For i = 1 To 4
                        ss = ss & "" & brr((q - 1) * 4 + i, 19)
                        For j = 1 To 18
                            If n >= (q - 1) + i Then crr(i, j) = brr((q - 1) * 4 + i, j)
                        Next j
                    Next i
                .Range("I5") = ss
                .Range("B8").Resize(4, 18) = crr
                .Range("B2:T14").PrintPreview
                .Range("B2:T14").PrintOut
            End With
        Next q
    Sheet1.Activate
    Application.ScreenUpdating = True
End Sub

Sub Optik()
    Sheet1.Range("H3:J3,F5,I5:S5,B8:S11") = ""
End Sub



最佳答案
2017-5-22 17:01
你自己添加一个生成按钮吧,然后添加以下相应代码。
  1. Sub 打印()
  2.     Sheet1.Range("B2:T14").PrintPreview
  3. End Sub

  4. Sub 生成()
  5.     Dim arr, brr(), crr(1 To 4, 1 To 18), d, K, i%, j%, q, Y, n, a, ss
  6.     Application.ScreenUpdating = False
  7.     Set d = CreateObject("scripting.dictionary")
  8.     arr = Sheet2.Range("A3").CurrentRegion
  9.         For i = 4 To UBound(arr)
  10.            If arr(i, 12) <> "" Then d(arr(i, 5) & "+" & arr(i, 14)) = ""
  11.         Next i
  12.     K = d.keys
  13.     a = Sheet1.Range("V3")
  14.         For j = 0 To UBound(K)
  15.             n = 0: ss = ""
  16.             For i = 4 To UBound(arr)
  17.                 ReDim Preserve brr(1 To UBound(arr), 1 To 18)
  18.                 If arr(i, 1) <> "" And arr(i, 5) & "+" & arr(i, 14) = a Then
  19.                     n = n + 1
  20.                     brr(n, 1) = arr(i, 1)
  21.                     brr(n, 2) = arr(i, 2)
  22.                     brr(n, 3) = arr(i, 3)
  23.                     brr(n, 4) = arr(i, 4)
  24.                     brr(n, 5) = arr(i, 6) & "--" & arr(i, 7)
  25.                     brr(n, 10) = arr(i, 9)
  26.                     brr(n, 13) = arr(i, 10)
  27.                     brr(n, 16) = arr(i, 11)
  28.                     brr(n, 18) = arr(i, 12)
  29.                     ss = ss & "," & arr(i, 8)
  30.                 End If
  31.             Next i
  32.         Next j
  33.         Y = Application.RoundUp(n / 4, 0)
  34.         For q = 1 To Y
  35.             With Sheet1
  36.                 .Range("E3,F5,H3:J3,I5:S5,B8:S11") = ""
  37.                 .Range("H3") = Split(a, "+")(1)
  38.                 .Range("F5") = Split(a, "+")(0)
  39.                 .Range("I5") = ss
  40.                     For i = 1 To 4
  41.                         For j = 1 To 18
  42.                             If n >= (q - 1) + i Then crr(i, j) = brr((q - 1) * 4 + i, j)
  43.                         Next j
  44.                     Next i
  45.                 .Range("B8").Resize(4, 18) = crr
  46.             End With
  47.         Next q
  48.     Sheet1.Activate
  49.     Application.ScreenUpdating = True
  50. End Sub

  51. Sub Optik()
  52.     Sheet1.Range("E3,F5,H3:J3,I5:S5,B8:S11") = ""
  53. End Sub
复制代码

如图片上的是几次出差的事由,分别在每次出差事由后用顿号隔开!

如图片上的是几次出差的事由,分别在每次出差事由后用顿号隔开!

差旅模板--直接打印.rar

29.88 KB, 下载次数: 3

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-5-22 11:12 | 显示全部楼层
把  .Range("B2:T14").PrintOut 改成   .Range("B2:T14").PrintPreview
回复

使用道具 举报

 楼主| 发表于 2017-5-22 11:21 | 显示全部楼层
grf1973 发表于 2017-5-22 11:12
把  .Range("B2:T14").PrintOut 改成   .Range("B2:T14").PrintPreview

老师,VBA代码中有这个啊
QQ截图20170522112023.png
回复

使用道具 举报

发表于 2017-5-22 12:36 | 显示全部楼层
'                .Range("B2:T14").PrintPreview
这句在原代码中被注释掉了,你把.Range("B2:T14").PrintOut注释掉,再把上面那句取消注释。
回复

使用道具 举报

 楼主| 发表于 2017-5-22 15:26 | 显示全部楼层
大灰狼1976 发表于 2017-5-22 12:36
'                .Range("B2:T14").PrintPreview
这句在原代码中被注释掉了,你把.Range("B2:T14").Print ...

谢谢老师指导
还想请教老师,请问能不能在代码中直接添加一个“生成”按钮,点选后直接点生成按钮就可以不在预览模式下生成数据?老师能否帮我把附件修改一下?
回复

使用道具 举报

发表于 2017-5-22 16:57 | 显示全部楼层
代码中添加按钮的意思是先点击工作表中的打印按钮,然后出现一个生成按钮?还是在工作表中添加一个生成按钮?不太明白你的意思。
回复

使用道具 举报

发表于 2017-5-22 17:01 | 显示全部楼层    本楼为最佳答案   
你自己添加一个生成按钮吧,然后添加以下相应代码。
  1. Sub 打印()
  2.     Sheet1.Range("B2:T14").PrintPreview
  3. End Sub

  4. Sub 生成()
  5.     Dim arr, brr(), crr(1 To 4, 1 To 18), d, K, i%, j%, q, Y, n, a, ss
  6.     Application.ScreenUpdating = False
  7.     Set d = CreateObject("scripting.dictionary")
  8.     arr = Sheet2.Range("A3").CurrentRegion
  9.         For i = 4 To UBound(arr)
  10.            If arr(i, 12) <> "" Then d(arr(i, 5) & "+" & arr(i, 14)) = ""
  11.         Next i
  12.     K = d.keys
  13.     a = Sheet1.Range("V3")
  14.         For j = 0 To UBound(K)
  15.             n = 0: ss = ""
  16.             For i = 4 To UBound(arr)
  17.                 ReDim Preserve brr(1 To UBound(arr), 1 To 18)
  18.                 If arr(i, 1) <> "" And arr(i, 5) & "+" & arr(i, 14) = a Then
  19.                     n = n + 1
  20.                     brr(n, 1) = arr(i, 1)
  21.                     brr(n, 2) = arr(i, 2)
  22.                     brr(n, 3) = arr(i, 3)
  23.                     brr(n, 4) = arr(i, 4)
  24.                     brr(n, 5) = arr(i, 6) & "--" & arr(i, 7)
  25.                     brr(n, 10) = arr(i, 9)
  26.                     brr(n, 13) = arr(i, 10)
  27.                     brr(n, 16) = arr(i, 11)
  28.                     brr(n, 18) = arr(i, 12)
  29.                     ss = ss & "," & arr(i, 8)
  30.                 End If
  31.             Next i
  32.         Next j
  33.         Y = Application.RoundUp(n / 4, 0)
  34.         For q = 1 To Y
  35.             With Sheet1
  36.                 .Range("E3,F5,H3:J3,I5:S5,B8:S11") = ""
  37.                 .Range("H3") = Split(a, "+")(1)
  38.                 .Range("F5") = Split(a, "+")(0)
  39.                 .Range("I5") = ss
  40.                     For i = 1 To 4
  41.                         For j = 1 To 18
  42.                             If n >= (q - 1) + i Then crr(i, j) = brr((q - 1) * 4 + i, j)
  43.                         Next j
  44.                     Next i
  45.                 .Range("B8").Resize(4, 18) = crr
  46.             End With
  47.         Next q
  48.     Sheet1.Activate
  49.     Application.ScreenUpdating = True
  50. End Sub

  51. Sub Optik()
  52.     Sheet1.Range("E3,F5,H3:J3,I5:S5,B8:S11") = ""
  53. End Sub
复制代码

评分

参与人数 1 +8 收起 理由
france723 + 8 来学习

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-5-22 17:52 | 显示全部楼层
大灰狼1976 发表于 2017-5-22 17:01
你自己添加一个生成按钮吧,然后添加以下相应代码。

谢谢老师的指导!!!小弟在不断学习中!!!
回复

使用道具 举报

 楼主| 发表于 2017-5-22 22:00 | 显示全部楼层
大灰狼1976 发表于 2017-5-22 17:01
你自己添加一个生成按钮吧,然后添加以下相应代码。

老师,能不能再帮我改一下这个代码?谢谢老师!!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 09:33 , Processed in 1.360524 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表