关于每个员工每月工资变化的明细

shyshine78

表1罗列的是全校老师2015年1月份收入的变化明细
表2是把每一位老师分开来，去除空白的内容项，用于打印出来分发给每位老师，已告知他们2015年1月中变化的具体明细。

如何把表1中的内容自动变成表2中的内容

表1中的项目数每个月是可以不同的，教师人数是可以增加的。

每个月可以单独做一个excel文件。

谢谢大家了，如何做啊。帮帮忙，大侠们。

2015年工资补发、扣款统计.rar (10.51 KB, 下载次数: 59)

2014-12-26 16:24 上传

点击文件名下载附件

TomingTang

1. Sub 拆分()
   
2.     Dim Arr, Brr, drow%, i%, j%, rng As Range, Crr()
   
3.     Arr = Worksheets("表1").Range("a1").CurrentRegion
   
4.     Set rng = Worksheets("表2").Range("a1:a2")
   
5.     With Worksheets("sheet1")
   
6.         For i = 2 To UBound(Arr)
   
7.             k = 3
   
8.             ReDim Crr(1 To 2, 1 To UBound(Arr, 2) + 2)
   
9.             Crr(1, 1) = Arr(1, 1): Crr(1, 2) = Arr(1, 2): Crr(2, 1) = Arr(i, 1): Crr(2, 2) = Arr(i, 2)
   
10.             For j = 3 To UBound(Arr, 2)
    
11.                 If Arr(i, j) <> "" Then
    
12.                     Crr(1, k) = Arr(1, j): Crr(2, k) = Arr(i, j): k = k + 1
    
13.                 End If
    
14.             Next
    
15.             drow = .Range("a65536").End(3).Row
    
16.             rng.Copy .Cells(drow + 3, 1)
    
17.             .Range("b" & drow + 3).Resize(2, k) = Crr
    
18.             With .Range(.Cells(drow + 3, 1), .Cells(drow + 4, k))
    
19.                 .Borders(xlEdgeTop).LineStyle = xlContinuous
    
20.                 .Borders(xlEdgeLeft).LineStyle = xlContinuous
    
21.                 .Borders(xlEdgeBottom).LineStyle = xlContinuous
    
22.                 .Borders(xlEdgeRight).LineStyle = xlContinuous
    
23.                 .Borders(xlInsideVertical).LineStyle = xlContinuous
    
24.                 .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    
25.             End With
    
26.             Erase Crr
    
27.         Next
    
28.     End With
    
29. 
    
30. End Sub
    

复制代码

TomingTang

我弄了一个放在sheet1中。速度、格式都待优化，看看是不是你所需要的。水平有限。

TomingTang

1. Sub 拆分1()
   
2.     Dim Arr, Brr, drow%, i%, j%, rng As Range, Crr()
   
3.     Arr = Worksheets("表1").Range("a1").CurrentRegion
   
4.     Set rng = Worksheets("表2").Range("a1:a2")
   
5.     With Worksheets("sheet1")
   
6.         For i = 2 To UBound(Arr)
   
7.             k = 3
   
8.             ReDim Crr(1 To 2, 1 To UBound(Arr, 2) + 2)
   
9.             Crr(1, 1) = Arr(1, 1): Crr(1, 2) = Arr(1, 2): Crr(2, 1) = Arr(i, 1): Crr(2, 2) = Arr(i, 2)
   
10.             For j = 3 To UBound(Arr, 2)
    
11.                 If Arr(i, j) <> "" Then
    
12.                     Crr(1, k) = Arr(1, j): Crr(2, k) = Arr(i, j): k = k + 1
    
13.                 End If
    
14.             Next
    
15.             drow = .Range("a65536").End(3).Row
    
16.             rng.Copy .Cells(drow + 3, 1)
    
17.             .Range("b" & drow + 3).Resize(2, k) = Crr
    
18.             .Range(.Cells(drow + 3, 1), .Cells(drow + 4, k)).Borders.LineStyle = 1
    
19.             Erase Crr
    
20.         Next
    
21.     End With
    
22. 
    
23. End Sub
    

复制代码

修改了一下。看看。

shyshine78

万分感谢，实在太好用了。

shyshine78

如果表1和表2的要求有点变化，具体见附件。如何使得表1自动变为表2.其中表1中的项目数每个月是可以不同的，教师人数是可以增加的。谢谢