江湖急救---资产负债表转置变换

martychan

已知有一个总的文件夹，每个文件夹又有6个folder，每个folder有对应的BS表，其中每个BS表的列不完全一致，现在需要合并汇总成图片中的格式

martychan

已经解决了部分问题，想用数组来实现，可惜效率太低，运行不出来结果。

1. Sub 测试()
   
2. '
   
3. ' 测试 宏
   
4. 
   
5. 
   
6. Dim fso, f, n&
   
7. Dim m As Integer
   
8. Dim iR, i, j, k, z, y As Integer
   
9. Dim 科目, data, temp
   
10. Dim FilePath, FilePath2, MyStr  As String
    
11. 
    
12. Dim WB As Workbook
    
13. 
    
14.   FilePath = ThisWorkbook.Path
    
15.   FilePath = FilePath & IIf(Right(FilePath, 1) = "", "", "")
    
16.    n = 1
    
17.    Set fso = CreateObject("Scripting.FileSystemObject")
    
18. 
    
19.      For Each floder1 In fso.GetFolder(FilePath).SubFolders
    
20. 
    
21.           FilePath = FilePath & floder1.Name & IIf(Right(FilePath, 1) = "", "", "")
    
22.          
    
23.         For Each f In floder1.Files
    
24.           MyStr = f.Name
    
25.           With CreateObject("VBSCRIPT.REGEXP")
    
26.               .Pattern = "balance statement+"
    
27.               .Global = True
    
28.               
    
29.             If .TEST(MyStr) Then Cells(n, 2) = FilePath & MyStr: n = n + 1
    
30.         
    
31.             End With
    
32.          
    
33.         Next
    
34.         '  Workbooks(FilePath & MyStr).Close
    
35.          
    
36.          
    
37.   FilePath = ThisWorkbook.Path
    
38.   FilePath = FilePath & IIf(Right(FilePath, 1) = "", "", "")
    
39. 
    
40. 
    
41.     Next
    
42.      
    
43.      iR = Range("B1").End(xlDown).Row
    
44.    ' Cells(2, 4) = iR
    
45.    
    
46.    
    
47.   
    
48. 
    
49.    
    
50.      FilePath = Cells(1, 2)
    
51.      Set WB = Workbooks.Open(FilePath)
    
52.      '  y = WB.Sheets("sheet1").Sheets("balance statement_EBBI10").Cells(1, 1).End(xlDown).Row
    
53.      '  ReDim 科目(1 To y)
    
54.        科目 = WB.Sheets(1).Columns(1).Value
    
55.     ' 科目 = WB.Columns(1).Value
    
56.    
    
57.        ReDim data(1 To UBound(科目), 1 To 2)
    
58.       
    
59.      data = WB.Sheets(1).Range(Cells(1, 1), Cells(UBound(科目), 2))
    
60.    ' MsgBox 科目(14, 1)
    
61.       
    
62. '  MsgBox data(14, 2)
    
63. 
    
64. 
    
65. 'Workbooks(FilePath).Close
    
66.    '------------------------------------------------------------------------------------
    
67.      Rem  ReDim Preserve arr(1 To UBound(科目), 1 To iR + 1)
    
68.    Rem =============================================================
    
69.      '  For z = 1 To UBound(科目) + 1
    
70.      '   arr(z, 1) = WB.Sheets("balance statement_EBBI10").Cells(z, 1).Value
    
71.       '  arr(z, 2) = WB.Sheets("balance statement_EBBI10").Cells(z, 2).Value
    
72.       '  Next z
    
73.    WB.Close
    
74.    
    
75.     ReDim Preserve data(1 To UBound(科目), 1 To iR * 2)
    
76.     For i = 2 To iR
    
77.    
    
78.      FilePath = Cells(i, 2)
    
79.      Set WB = Workbooks.Open(FilePath)
    
80.      
    
81.     '  ReDim Preserve data(1 To UBound(科目), 1 To i * 2)
    
82.        ReDim temp(1 To UBound(科目), 1 To 2)
    
83.       
    
84.    temp = WB.Sheets(1).Range(Cells(1, 1), Cells(UBound(科目), 2))
    
85.     For j = 1 To UBound(科目)
    
86.        ' For k = 0 To UBound(科目)
    
87.          ' If arr(k, 1) = data(j, 1) Then data(j, i + 1) = arr(k, 2)
    
88.     ' End If
    
89.     '  Next k
    
90.     '  Next j
    
91.    ' data(j, 2 * i - 1) = WB.Sheets(1).Cells(j, 1)
    
92.    ' data(j, 2 * i) = WB.Sheets(1).Cells(j, 2)
    
93.      data(, 2 * i - 1) = WB.Sheets(1).Columns(1)
    
94.      data(, 2 * i) = WB.Sheets(1).Columns(2)
    
95.     Next j
    
96.      WB.Close
    
97.   Next i
    
98.    
    
99. MsgBox data(1, 4)
    
100. 'Range(Cells(1, 10), Cells(UBound(科目) + 1, 11 + iR)) = arr()
     
101. Rem ===================================================================='-------------------------------------------------------------------------
     
102. End Sub
     

复制代码