[已解决]求助精英修改代码20120627

syt188702

1. Option Explicit
   
2. Sub XXL()
   
3. Dim t, D1
   
4. 
   
5. Application.Calculation = xlCalculationAutomatic '自动重算
   
6. Dim MyrO&, ArrO, III
   
7. MyrO = Sheets("现金流水").[A65536].End(xlUp).Row 'A列最后一个非空单元格
   
8. ArrO = Sheets("现金流水").Range("A2:R" & MyrO) '把数据表的使用区域纳入数组
   
9. Dim Maxrow, Rwct
   
10. Dim Myr&, i&, Arr, Brr(1 To 14)
    
11. Dim D As New Dictionary 'scrrun.dll后期绑定
    
12. Dim J, R, Arr1(), II
    
13. Set D1 = CreateObject("Scripting.Dictionary")
    
14. Myr = Sheets("数据表").[b65536].End(xlUp).Row 'B列最后一个非空单元格
    
15. Arr = Sheets("数据表").Range("b2:Q" & Myr) '把数据表的使用区域纳入数组
    
16. For i = 1 To UBound(Arr) '在数组中循环
    
17. D(Arr(i, 1)) = ""
    
18. Next
    
19. Application.EnableEvents = False
    
20. If Sheets("最终效果").Range("AX2") - 1 >= D.Count Then MsgBox "已到最后一页": Sheets("最终效果").Range("AX2") = D.Count: Exit Sub
    
21. Sheets("单户").Range("b2") = D.Keys(Sheets("最终效果").Range("AX2") - 1)
    
22. For i = 1 To UBound(Arr)
    
23. If Arr(i, 1) = Sheets("单户").Range("b2") Then
    
24. Brr(1) = Arr(i, 2) '客户名称
    
25. Brr(2) = Arr(i, 3) '借据号码
    
26. For J = 3 To 14 '贷款余额 ~ 综合业务账号
    
27. Brr(J) = Arr(i, J + 2)
    
28. Next
    
29. Sheets("单户").Range("C2").Resize(1, 14) = Brr '将结果写入 C2:P2 单元格
    
30. R = R + 1
    
31. 
    
32. ReDim Preserve Arr1(1 To 8, 1 To R) 'Arr1(1 To 8列, 1 To R行)
    
33. 
    
34. If Sheets("单户").Range("G2") = "" Then
    
35. Arr1(1, R) = Sheets("单户").Range("b5").Value '新放与上年余额订位日期
    
36. Arr1(2, R) = "上年结转"
    
37. Else
    
38. Arr1(1, R) = Sheets("单户").Range("j2").Value '借款日期
    
39. Arr1(2, R) = Sheets("单户").Range("I2").Value '借款用途
    
40. End If
    
41. Arr1(3, R) = Sheets("单户").Range("G2").Value '发放金额
    
42. Arr1(5, R) = Sheets("单户").Range("M2").Value '年度结转
    
43. Arr1(6, R) = Sheets("单户").Range("F2").Value '贷款余额
    
44. Arr1(8, R) = Sheets("单户").Range("h2").Value '责任人
    
45. ' ***********************************************************
    
46. 
    
47. 
    
48. '请大师修改代码：
    
49. '1, Sheets("单户").Range("B2").Value =SHEETS("现金流水").Range("A2"&所有使用的行).,筛选贷款帐号相同的发生额
    
50. 
    
51. '2,从现金流水表中的D,E,F,G,R列中取数,分别写入单户表中B8,E8,R8,H8,G8
    
52. 
    
53. If Sheets("单户").Range("B2").Value = Sheets("现金流水").Range("A2" & MyrO) Then
    
54. For III = 1 To UBound(ArrO())
    
55. D1(ArrO(III, 1)) = ""
    
56. Next
    
57. R = R + 1
    
58. ReDim Preserve Arr1(1 To 8, 1 To R)
    
59. Arr1(1, R) = ArrO(III, 4) 'Sheets("现金流水").Range("D2" & MyrO).Value
    
60. 
    
61. Arr1(4, R) = ArrO(III, 5) 'Sheets("现金流水").Range("E2" & MyrO).Value
    
62. 
    
63. Arr1(7, R) = ArrO(III, 6) 'Sheets("现金流水").Range("F2" & MyrO).Value
    
64. 
    
65. Arr1(5, R) = ArrO(III, 18) 'Sheets("现金流水").Range("R2" & MyrO).Value
    
66. 
    
67. If Arr1(4, R) And Arr1(7, R) > 0 Then
    
68. Arr1(2, R) = "本息收回"
    
69. Else
    
70. Arr1(2, R) = "仅收利息"
    
71. End If
    
72. 
    
73. If R = 1 Then
    
74. Arr1(6, R) = [f2].Value - Arr1(4, R)
    
75. Else
    
76. Arr1(6, R) = Arr1(6, R - 1) - Arr1(4, R)
    
77. End If
    
78. Arr1(8, R) = [H2].Value
    
79. Else
    
80. Exit For
    
81. 
    
82. 
    
83. '*********************************************************************************************
    
84. Sheets("单户").Range("b7:i100").ClearContents 'Clear
    
85. If R <> 0 Then
    
86. Sheets("单户").[b7].Resize(R, 8) = Application.Transpose(Arr1)
    
87. 'With Sheets("单户").[b6].Resize(R + 1, 8)
    
88. ' .Borders.LineStyle = 1
    
89. ' .Font.Name = "仿宋_GB2312"
    
90. ' .Font.Size = 9
    
91. ' End With
    
92. End If
    
93. Exit For
    
94. End If
    
95. 'Next
    
96. With Sheets("最终效果")
    
97. 
    
98. Range("A6:AU20").ClearContents
    
99. Range("C3,N3:AA3,AG3:AO3,AS3:AW3,AV2:AW2,AV6").ClearContents
    
100. Maxrow = 6
     
101. ' With Sheets("单户")
     
102. Rwct = Sheets("单户").Range("B65536").End(xlUp).Row
     
103. If Sheets("单户").Cells(2, 2) <> "" Then
     
104. Cells(3, 45) = Sheets("单户").Cells(2, 2)
     
105. Cells(3, 7) = Sheets("单户").Cells(2, 3)
     
106. Cells(2, 48) = Sheets("单户").Cells(2, 4)
     
107. Cells(3, 3) = Sheets("单户").Cells(2, 5)
     
108. Cells(3, 33) = Sheets("单户").Cells(2, 14)
     
109. Cells(3, 14) = Sheets("单户").Cells(2, 15)
     
110. Cells(6, 48) = Sheets("单户").Cells(7, 9)
     
111. Cells(28, 41) = "结算帐号" & Sheets("单户").Cells(2, 16)
     
112. End If
     
113. For i = Maxrow To Rwct
     
114. If Sheets("单户").Cells(1 + i, 2) <> "" Then '记帐日期
     
115. Cells(4, 1) = Right(Year(Sheets("单户").Cells(7, 2)), 2) '年2位
     
116. Cells(i, 1) = Format(Month(Sheets("单户").Cells(1 + i, 2)), "00") '月2位
     
117. Cells(i, 2) = Format(Day(Sheets("单户").Cells(1 + i, 2)), "00") '日2位
     
118. Cells(i, 10) = Sheets("单户").Cells(i - 4, 12) '利率
     
119. End If
     
120. If Sheets("单户").Cells(1 + i, 2) <> "" Then
     
121. Cells(6, 4) = Right(Year(Sheets("单户").Cells(2, 10)), 2) '年2位
     
122. Cells(6, 5) = Format(Month(Sheets("单户").Cells(2, 10)), "00") '月2位
     
123. Cells(6, 6) = Format(Day(Sheets("单户").Cells(2, 10)), "00") '日2位
     
124. Cells(6, 7) = Right(Year(Sheets("单户").Cells(2, 11)), 2) '年2位
     
125. Cells(6, 8) = Format(Month(Sheets("单户").Cells(2, 11)), "00") '月2位
     
126. Cells(6, 9) = Format(Day(Sheets("单户").Cells(2, 11)), "00") '日2位
     
127. End If
     
128. If Sheets("单户").Cells(1 + i, 6) <> "" Then
     
129. Cells(i, 29) = Right(Year(Sheets("单户").Cells(1 + i, 6)), 2) '年2位
     
130. End If
     
131. If Sheets("单户").Cells(1 + i, 6) <> "" Then
     
132. Cells(i, 30) = Format(Month(Sheets("单户").Cells(1 + i, 6)), "00") '月2位
     
133. End If
     
134. If Sheets("单户").Cells(1 + i, 6) <> "" Then
     
135. Cells(i, 31) = Format(Day(Sheets("单户").Cells(1 + i, 6)), "00") '日2位
     
136. End If
     
137. If Sheets("单户").Cells(1 + i, 3) <> "" Then Cells(i, 3) = Sheets("单户").Cells(1 + i, 3)
     
138. If Sheets("单户").Cells(i + 1, 4) <> "" And Abs(Val(Sheets("单户").Cells(i + 1, 4))) >= 0 Then '借方金额分栏填充
     
139. VaToBranch CDbl(Val(Sheets("单户").Cells(i + 1, 4))), i, 11, 19
     
140. 
     
141. End If
     
142. If Sheets("单户").Cells(i + 1, 5) <> "" And Abs(Val(Sheets("单户").Cells(i + 1, 5))) >= 0 Then '贷方金额分栏填充
     
143. VaToBranch CDbl(Val(Sheets("单户").Cells(i + 1, 5))), i, 20, 28
     
144. 
     
145. End If
     
146. If Sheets("单户").Cells(i + 1, 7) <> "" And Abs(Val(Sheets("单户").Cells(i + 1, 7))) >= 0 Then '结存金额分栏填充
     
147. VaToBranch CDbl(Val(Sheets("单户").Cells(i + 1, 7))), i, 32, 40
     
148. End If
     
149. If Sheets("单户").Cells(i + 1, 8) <> "" And Abs(Val(Sheets("单户").Cells(i + 1, 8))) >= 0 Then '利息金额分栏填充
     
150. VaToBranch CDbl(Val(Sheets("单户").Cells(i + 1, 8))), i, 41, 47
     
151. End If
     
152. Next i
     
153. End With
     
154. 
     
155. Application.EnableEvents = True '打开事件
     
156. 
     
157. 
     
158. 
     
159. 
     
160. 
     
161. End Sub
     
162. Function VaToBranch(ByVal Sg#, ByVal rwC As Integer, ByVal Stcol As Integer, ByVal Edcol As Integer)
     
163. Dim i, N, vLen As Integer
     
164. Dim vLstr As String
     
165. vLstr = Replace(CStr(Format(Sg, "0.00")), ".", "") '把数字格式的点替换为空
     
166. vLen = Len(vLstr) '数字的长度
     
167. For i = 1 To vLen '变量i的取值范围是1-数字去小数点的长度
     
168. Cells(rwC, Edcol - vLen + i) = Mid(vLstr, i, 1) '用mid()循环取值
     
169. Next i
     
170. End Function '分列函数摘自论坛凭证处理130的
     
171. 
     

复制代码

我在*********和*******中加入代码后，无法运行了
请大师们帮帮，谢谢

最佳答案

月排行榜 / 总排行榜

zjdh

2012-6-30 13:52

(, 下载次数: 24)

上传

点击文件名下载附件

跳转到最佳答案楼层

zjdh

你就是没在*********和*******中加入代码，也同样无法运行！
因为第2个 for i=....  没有next对应
新添的语句中有if......else.... 没有end if  更无法运行啦！！

syt188702

zjdh 发表于 2012-6-27 19:08
你就是没在*********和*******中加入代码，也同样无法运行！
因为第2个 for i=....  没有next对应
新添的 ...

请老师帮忙解一下代码，我知识有限，无从下手

syt188702

zjdh 发表于 2012-6-27 19:08
你就是没在*********和*******中加入代码，也同样无法运行！
因为第2个 for i=....  没有next对应
新添的 ...

请老师看看，没有加代码，以原代码中的单户B2为条件从现金流水中调发生额，如现金流水中没有发生额就运行现在的代码

syt188702

zjdh 发表于 2012-6-27 19:08
你就是没在*********和*******中加入代码，也同样无法运行！
因为第2个 for i=....  没有next对应
新添的 ...

老师改了已不行，请老师帮助

zjdh

syt188702 发表于 2012-6-27 19:44
请老师看看，没有加代码，以原代码中的单户B2为条件从现金流水中调发生额，如现金流水中没有发生额就运行 ...

1楼代码中把第95句注销掉了！
本楼附件next 又回来了！

syt188702

zjdh 发表于 2012-6-27 20:45
1楼代码中把第95句注销掉了！
本楼附件next 又回来了！

老师代码运行了，但没有从现金流水表中调来发生额，请帮忙改改，谢谢

syt188702

zjdh 发表于 2012-6-27 20:45
1楼代码中把第95句注销掉了！
本楼附件next 又回来了！

敬请老师再次伸出援助之手吧

syt188702

zjdh 发表于 2012-6-27 20:45
1楼代码中把第95句注销掉了！
本楼附件next 又回来了！

东海老师，请帮助我完善这个贷款台帐吧，去年得到您的帮助在此表示谢谢，（从邮箱里发给老师函数台帐，经过老师们用VBA给减肥从20多MB减少到2MB）运行很好，但由于执行新会计制度，原数据库设计有缺陷，只能取12次发生额。

zjdh

求助.rar (113.3 KB, 下载次数: 7)

2012-6-29 20:55 上传

点击文件名下载附件