[已解决]金额各数字分别列填

xdwy81129

如题

要求见附件和图片

1.为空白时不填写，把常规的数字按照圆角分来列填

注意还有负号的和为0的处理。

谢谢赐教了，需要用数组解决

金额各数字分别列填.rar (8.7 KB, 下载次数: 10)

2011-1-17 21:01 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

那么的帅

2011-1-17 21:56

1. Sub 填充()
   
2. Dim arr2()
   
3. row1 = Sheets(1).Range("H65536").End(xlUp).Row
   
4. arr1 = Sheets(1).Range("h7:h" & row1)
   
5. ReDim arr2(1 To UBound(arr1), 1 To 12)
   
6. For i = 1 To UBound(arr1)
   
7. If IsNumeric(arr1(i, 1)) Then
   
8. x = CStr(arr1(i, 1) * 100)
   
9. If x = "0" Then x = "000"
   
10. For j = 1 To Len(x)
    
11. arr2(i, 13 - j) = Mid(x, Len(x) + 1 - j, 1)
    
12. Next j
    
13. End If
    
14. Next i
    
15. Sheets(1).Range("y7").Resize(UBound(arr1), 12) = arr2
    
16. End Sub

复制代码

金额各数字分别列填(VBA).rar (15.86 KB, 下载次数: 11)

2011-1-17 21:56 上传

点击文件名下载附件

跳转到最佳答案楼层

那么的帅

不是已经填好了吗？

xdwy81129

回复 那么的帅 的帖子

那是函数填的，求的是vba，认为数组很快，所以求数组方法

liuguansky

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Count > 1 Then Exit Sub
   
3.     If Target.Column = 8 And IsNumeric(Target.Value) Then
   
4.         Dim str1$, arr(), k%, i%
   
5.         str1 = Replace(Format(Target.Value, "0.00"), ".", "")
   
6.         k = Len(str1)
   
7.         If k > 12 Then MsgBox "输入数据过大,超出可核算范围。": Exit Sub
   
8.         ReDim arr(1 To 1, 1 To 12)
   
9.         For i = 1 To 12
   
10.             arr(1, i) = Left(Right(" " & str1, 13 - i), 1)
    
11.         Next i
    
12.         Cells(Target.Row, "y").Resize(1, 12) = arr
    
13.     End If
    
14. End Sub

复制代码

事件代码 金额各数字分别列填.rar (14.71 KB, 下载次数: 9)

2011-1-17 21:54 上传

点击文件名下载附件 。

那么的帅

1. Sub 填充()
   
2. Dim arr2()
   
3. row1 = Sheets(1).Range("H65536").End(xlUp).Row
   
4. arr1 = Sheets(1).Range("h7:h" & row1)
   
5. ReDim arr2(1 To UBound(arr1), 1 To 12)
   
6. For i = 1 To UBound(arr1)
   
7. If IsNumeric(arr1(i, 1)) Then
   
8. x = CStr(arr1(i, 1) * 100)
   
9. If x = "0" Then x = "000"
   
10. For j = 1 To Len(x)
    
11. arr2(i, 13 - j) = Mid(x, Len(x) + 1 - j, 1)
    
12. Next j
    
13. End If
    
14. Next i
    
15. Sheets(1).Range("y7").Resize(UBound(arr1), 12) = arr2
    
16. End Sub

复制代码

金额各数字分别列填(VBA).rar (15.86 KB, 下载次数: 11)

2011-1-17 21:56 上传

点击文件名下载附件

xdwy81129

学习最佳答案

wmy920130

正是需要时

wmy920130

看看怎么搞的