设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求助VBA将金额分解！
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1916|回复: 4

[已解决]求助VBA将金额分解！

[复制链接]
lgpoo
发表于 2012-1-7 13:47 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
比如是9876543.21元，通过VBA分解成打印凭证中的 9一格，8一格，依次类推
如果用函数解决，这就比较大了，能否用VBA解决！求解！
最佳答案
月排行榜 / 总排行榜
sunjing-zxl
2012-1-9 11:50
本帖最后由 sunjing-zxl 于 2012-1-9 11:51 编辑
  1. Sub 录入数据()
  2.     Dim sht As Worksheet
  3.     Dim i As Long, j As Long, k As Long
  4.     Dim arr, arr1
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     Application.ScreenUpdating = False
  7.     arr = Range("A2:G" & [E65536].End(xlUp).Row)
  8.     For i = 1 To UBound(arr)
  9.         d(arr(i, 2)) = d.Count + 1
  10.     Next i
  11.     For i = 1 To d.Count
  12.         Set sht = Sheets.Add
  13.         sht.Name = i
  14.         Sheets("凭证打印").Cells.Copy
  15.         With Sheets(sht.Name).Range("A1")
  16.             .PasteSpecial Paste:=xlPasteFormats
  17.             .PasteSpecial Operation:=xlNone
  18.             .PasteSpecial SkipBlanks:=False
  19.             .PasteSpecial Transpose:=False
  20.             .Range("A1").Activate
  21.         End With
  22.         arr1 = Sheets(sht.Name).Range("A1:AB13")
  23.         n = 0
  24.         For j = 1 To UBound(arr)
  25.             If arr(j, 2) = sht.Name Then
  26.                 n = n + 1
  27.                 If n = 1 Then
  28.                     arr1(2, 3) = arr(j, 1)
  29.                 End If
  30.                 arr1(4 + n, 3) = arr(j, 5)
  31.                 If arr(j, 6) <> "" Then
  32.                     For k = 1 To Len(arr(j, 6) * 100)
  33.                         arr1(4 + n, 14 - k) = Mid(arr(j, 6) * 100, Len(arr(j, 6) * 100) + 1 - k, 1)
  34.                     Next k
  35.                 End If
  36.                 If arr(j, 7) <> "" Then
  37.                     For k = 1 To Len(arr(j, 7) * 100)
  38.                         arr1(4 + n, 27 - k) = Mid(arr(j, 7) * 100, Len(arr(j, 7) * 100) + 1 - k, 1)
  39.                     Next k
  40.                 End If
  41.             End If
  42.         Next j
  43.         Sheets(sht.Name).Range("A1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
  44.     Next i
  45.     Application.ScreenUpdating = True
  46. End Sub

复制代码
附件： Book1-sunjing.rar (14.32 KB, 下载次数: 33)

Book1.rar

3.26 KB, 下载次数: 10
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
lgpoo
 楼主| 发表于 2012-1-8 15:17 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
求助高手  或用函数解决 也行
最好是简便一点的函数
回复

使用道具 举报

lgpoo
 楼主| 发表于 2012-1-8 17:16 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
求助高手！！！
回复

使用道具 举报

发表于 2012-1-8 17:30 | 显示全部楼层
可以。
但我不是会计，所以请就你附件中提供的数据做手工几张你需要的凭证吧。
回复

使用道具 举报

发表于 2012-1-9 11:50 | 显示全部楼层    本楼为最佳答案   
本帖最后由 sunjing-zxl 于 2012-1-9 11:51 编辑
  1. Sub 录入数据()
  2.     Dim sht As Worksheet
  3.     Dim i As Long, j As Long, k As Long
  4.     Dim arr, arr1
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     Application.ScreenUpdating = False
  7.     arr = Range("A2:G" & [E65536].End(xlUp).Row)
  8.     For i = 1 To UBound(arr)
  9.         d(arr(i, 2)) = d.Count + 1
  10.     Next i
  11.     For i = 1 To d.Count
  12.         Set sht = Sheets.Add
  13.         sht.Name = i
  14.         Sheets("凭证打印").Cells.Copy
  15.         With Sheets(sht.Name).Range("A1")
  16.             .PasteSpecial Paste:=xlPasteFormats
  17.             .PasteSpecial Operation:=xlNone
  18.             .PasteSpecial SkipBlanks:=False
  19.             .PasteSpecial Transpose:=False
  20.             .Range("A1").Activate
  21.         End With
  22.         arr1 = Sheets(sht.Name).Range("A1:AB13")
  23.         n = 0
  24.         For j = 1 To UBound(arr)
  25.             If arr(j, 2) = sht.Name Then
  26.                 n = n + 1
  27.                 If n = 1 Then
  28.                     arr1(2, 3) = arr(j, 1)
  29.                 End If
  30.                 arr1(4 + n, 3) = arr(j, 5)
  31.                 If arr(j, 6) <> "" Then
  32.                     For k = 1 To Len(arr(j, 6) * 100)
  33.                         arr1(4 + n, 14 - k) = Mid(arr(j, 6) * 100, Len(arr(j, 6) * 100) + 1 - k, 1)
  34.                     Next k
  35.                 End If
  36.                 If arr(j, 7) <> "" Then
  37.                     For k = 1 To Len(arr(j, 7) * 100)
  38.                         arr1(4 + n, 27 - k) = Mid(arr(j, 7) * 100, Len(arr(j, 7) * 100) + 1 - k, 1)
  39.                     Next k
  40.                 End If
  41.             End If
  42.         Next j
  43.         Sheets(sht.Name).Range("A1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
  44.     Next i
  45.     Application.ScreenUpdating = True
  46. End Sub

复制代码
附件： Book1-sunjing.rar (14.32 KB, 下载次数: 33)
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-5-17 03:16 , Processed in 0.252789 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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