求VBA程序，拆分单元格数据转换为流水账

wllxf

C:\Users\Administrator\Desktop\捕获.JPG
什么都没有啊

地道战

抱歉，附件是有问题，已经更新。

地道战

顶顶顶！
顶顶顶！
顶顶顶！

不知道为什么

地道战 发表于 2018-6-6 10:17
这个论坛多年来都是国内EXCEL专业的TOP1，高手云集的地方。今天咋啦？高手呢？都潜水了？还是我的问题太难 ...

基本上没人关注的主要原因：
1、附件不规范
2、需求表述不简约 不清晰

地道战

我滴个娘哎。附件已经很规范了啊，怕表达不清晰，还做了示例，我也不知道要怎么做了。就是没见大神出手，急死我了。要命啊。大神在哪里？救救我啊。

yaojil

凑合着用吧

wllxf

搞定了，你看看

wllxf

1. Sub 拆分()
   
2.     Dim arr, brr, crr, drr, err, frr As Worksheet
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Sheet33.Range("A2:f65536").ClearContents
   
6.     m = Sheets.Count
   
7.     For k = 1 To m
   
8.         With Sheets(k)
   
9.             If .Name <> "总工资" And .Name <> "流水" Then
   
10.                 .Activate
    
11.                 ActiveWindow.DisplayFormulas = True
    
12.                 a = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.                 b = .Cells(2, .Columns.Count).End(xlToLeft).Column - 1
    
14.                 ReDim arr(1 To a - 2, 1 To b - 2)
    
15.                 ReDim brr(1 To a - 2)
    
16.                 ReDim crr(1 To a - 2)
    
17.                 ReDim drr(1 To b - 2)
    
18.                 For i = 3 To a
    
19.                     brr(i - 2) = .Cells(i, 1)
    
20.                     crr(i - 2) = .Cells(i, 2)
    
21.                     For j = 3 To b
    
22.                         If .Cells(i, j) <> "" Then
    
23.                             arr(i - 2, j - 2) = Replace(.Cells(i, j).Text, "=", "")
    
24.                         End If
    
25.                     Next
    
26.                 Next
    
27.                 For j = 3 To b
    
28.                     drr(j - 2) = .Cells(2, j)
    
29.                 Next
    
30.                 For i = 1 To a - 2
    
31.                     For j = 1 To b - 2
    
32.                         If arr(i, j) <> "" Then
    
33.                             err = Split(arr(i, j), "+")
    
34.                             c = UBound(err)
    
35.                             d = Sheet33.Cells(Sheet33.Rows.Count, 1).End(xlUp).Row + 1
    
36.                             For n = 0 To c
    
37.                                 Sheet33.Cells(d + n, 5) = err(n)
    
38.                                 Sheet33.Cells(d + n, 1) = crr(i)
    
39.                                 Sheet33.Cells(d + n, 2) = brr(i)
    
40.                                 Sheet33.Cells(d + n, 3) = .Name
    
41.                                 Sheet33.Cells(d + n, 4) = drr(j)
    
42.                             Next
    
43.                             err = ""
    
44.                         End If
    
45.                     Next
    
46.                 Next
    
47.                 ActiveWindow.DisplayFormulas = False
    
48.             End If
    
49.         End With
    
50.         arr = ""
    
51.         brr = ""
    
52.         crr = ""
    
53.         drr = ""
    
54.     Next
    
55.     Sheet33.Activate
    
56.     Application.DisplayAlerts = True
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    

复制代码

wllxf

wllxf 发表于 2018-6-7 15:22

代码修改了一下