[已解决]数据重新组合

wucj80

各位老师好，谁能帮我解决我这个问题

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-19 22:42

1. Sub 折分数据()
   
2.     Dim arr
   
3.     Dim i&, j&, k&, l&
   
4.     arr = Range("a1").CurrentRegion
   
5.     If UBound(arr) < 4 Then Exit Sub
   
6.     Dim data()
   
7.     ReDim data(1 To 5, 1 To 1)
   
8.     l = UBound(arr, 2)
   
9.     For i = 4 To UBound(arr)
   
10.         For j = 8 To l - 1
    
11.             If Len(arr(i, j)) > 0 Then
    
12.                 k = k + 1
    
13.                 ReDim Preserve data(1 To 5, 1 To k)
    
14.                 data(1, k) = arr(i, 1)
    
15.                 data(2, k) = arr(i, 2)
    
16.                 data(3, k) = arr(3, j)
    
17.                 data(4, k) = arr(i, j)
    
18.                 data(5, k) = arr(i, l)
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     If k > 0 Then
    
23.         With Worksheets("sheet2")
    
24.             .Range("a1").CurrentRegion.ClearContents
    
25.             .Range("a1").Resize(, 5) = Array("标题", "发生日期", "费用分类", "发生费用", "备注信息")
    
26.             .Range("a2").Resize(k, 5) = WorksheetFunction.Transpose(data)
    
27.             With .Range("a1").CurrentRegion.Borders
    
28.                 .LineStyle = xlContinuous
    
29.             End With
    
30.         End With
    
31.     End If
    
32. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

这次是逆向了，

hwc2ycy

1. Sub 折分数据()
   
2.     Dim arr
   
3.     Dim i&, j&, k&, l&
   
4.     arr = Range("a1").CurrentRegion
   
5.     If UBound(arr) < 4 Then Exit Sub
   
6.     Dim data()
   
7.     ReDim data(1 To 5, 1 To 1)
   
8.     l = UBound(arr, 2)
   
9.     For i = 4 To UBound(arr)
   
10.         For j = 8 To l - 1
    
11.             If Len(arr(i, j)) > 0 Then
    
12.                 k = k + 1
    
13.                 ReDim Preserve data(1 To 5, 1 To k)
    
14.                 data(1, k) = arr(i, 1)
    
15.                 data(2, k) = arr(i, 2)
    
16.                 data(3, k) = arr(3, j)
    
17.                 data(4, k) = arr(i, j)
    
18.                 data(5, k) = arr(i, l)
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     If k > 0 Then
    
23.         With Worksheets("sheet2")
    
24.             .Range("a1").CurrentRegion.ClearContents
    
25.             .Range("a1").Resize(, 5) = Array("标题", "发生日期", "费用分类", "发生费用", "备注信息")
    
26.             .Range("a2").Resize(k, 5) = WorksheetFunction.Transpose(data)
    
27.             With .Range("a1").CurrentRegion.Borders
    
28.                 .LineStyle = xlContinuous
    
29.             End With
    
30.         End With
    
31.     End If
    
32. End Sub

复制代码

wucj80

再一次感谢老师的精彩回应，很给力,谢谢