利用VBA整理 会计分录

chenyun1234

各位：

请帮帮忙，帮我看看我这样的EXCEL文件，怎么利用VBA强大的功能，实现转换！

说明:1、以序号作为第一判断条件，一个序号一整行代表一个完整的会计分录
       2、将序号为条件的一行数据整理为 【左边】这样的格式

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim r%, i%
   
4.   Dim arr, brr
   
5.   With Worksheets("转换格式")
   
6.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
   
7.     arr = .Range("a2:f" & r)
   
8.   End With
   
9.   For i = 1 To UBound(arr)
   
10.     If Len(arr(i, 1)) = 0 Then
    
11.       arr(i, 1) = arr(i - 1, 1)
    
12.     End If
    
13.     If Not d.Exists(arr(i, 1)) Then
    
14.       ReDim brr(1 To 6)
    
15.       For j = 1 To 6
    
16.         brr(j) = arr(i, j)
    
17.       Next
    
18.       d(arr(i, 1)) = brr
    
19.     Else
    
20.       brr = d(arr(i, 1))
    
21.       m = UBound(brr)
    
22.       ReDim Preserve brr(1 To m + 5)
    
23.       For j = 1 To 5
    
24.         brr(m + j) = arr(i, j + 1)
    
25.       Next
    
26.       d(arr(i, 1)) = brr
    
27.     End If
    
28.   Next
    
29.   With Worksheets("导出文件")
    
30.     .UsedRange.Offset(1, 0).ClearContents
    
31.     r = 1
    
32.     For Each aa In d.Keys
    
33.       r = r + 1
    
34.       brr = d(aa)
    
35.       .Cells(r, 1).Resize(1, UBound(brr)) = brr
    
36.     Next
    
37.   End With
    
38. End Sub
    

复制代码

chxw68

中午吃饭了，“借方合计”和“贷方合计”没来得及做。

qy1219no2

在“转换格式”的A列（序号）前插入一列“日期”，然后执行代码即可：

1. Sub test()
   
2.     Dim sj(), k%, i%, p%, m%
   
3.     With Sheets("导出文件")
   
4.         nR = .[a65536].End(xlUp).Row
   
5.         If nR < 2 Then Exit Sub
   
6.         arr = .[a2].Resize(nR - 1, 40)
   
7.     End With
   
8.     ReDim sj(6, 0): k = -1
   
9.     For i = 1 To nR - 1
   
10.         For p = 1 To 6
    
11.             If arr(i, 5 * p) <> "" Or arr(i, 5 * p + 1) <> "" Then
    
12.                 k = k + 1
    
13.                 ReDim Preserve sj(6, k)
    
14.                 sj(0, k) = DateSerial(Year(Date), arr(i, 39), arr(i, 40))
    
15.                 sj(1, k) = arr(i, 1)
    
16.                 For m = 1 To 5
    
17.                     sj(m + 1, k) = arr(i, 5 * p + m - 4)
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     If k < 0 Then Exit Sub
    
23.     With Sheets("转换格式")
    
24.         .[a2].Resize(65535, 7).ClearContents
    
25.         .[a2].Resize(k + 1, 7) = Application.Transpose(sj)
    
26.     End With
    
27. End Sub

复制代码

belinda0415

太棒了，非常感谢楼上的几位高手。

chenyun1234

qy1219no2 发表于 2014-6-4 12:33
在“转换格式”的A列（序号）前插入一列“日期”，然后执行代码即可：

您好：我想知道，您插入【日期】这列的数据取自哪来的？

chenyun1234

chxw68 发表于 2014-6-4 12:02
中午吃饭了，“借方合计”和“贷方合计”没来得及做。

老师：
  您帮我做的反了，我是要将【转出文件】变成【格式转换】，帮我看看呗

谢谢啦

qy1219no2

chenyun1234 发表于 2014-6-4 13:07
您好：我想知道，您插入【日期】这列的数据取自哪来的？

导出文件表中最后两列就是日期

belinda0415

chxw68 发表于 2014-6-4 12:02
中午吃饭了，“借方合计”和“贷方合计”没来得及做。

非常感谢您的回复，我把转换格式里A列至F列内容清除掉，结果出现“ 运行错误 '9' :
下标越界”，请问一下是什么原因？

chxw68

1. Sub test1()
   
2.   Dim r%, i%
   
3.   Dim arr, brr()
   
4.   With Worksheets("导出文件")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     c = .Rows("1:1").Find(what:="贷方金额", lookat:=xlWhole, searchdirection:=xlPrevious).Column
   
7.     arr = .Range("a2").Resize(r - 1, c)
   
8.   End With
   
9.   m = 0
   
10.   For i = 1 To UBound(arr)
    
11.     m = m + 1
    
12.     ReDim Preserve brr(1 To 6, 1 To m)
    
13.     For j = 1 To 6
    
14.       brr(j, m) = arr(i, j)
    
15.     Next
    
16.     For j = 7 To c Step 5
    
17.       If Len(arr(i, j + 1)) <> 0 Then
    
18.         m = m + 1
    
19.         ReDim Preserve brr(1 To 6, 1 To m)
    
20.         For k = 1 To 5
    
21.           brr(k + 1, m) = arr(i, j + k - 1)
    
22.         Next
    
23.       End If
    
24.     Next
    
25.   Next
    
26.   With Worksheets("转换格式")
    
27.     .UsedRange.Offset(1, 0).ClearContents
    
28.     .Range("a2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
29.   End With
    
30. End Sub

复制代码