整理excel表格数据，求高手优化vba代码！

mencius372

原始表格是这个样子的，默认有很多这样的表格。能批量整理，比如把原始表放在 XX 文件夹。
然后运行代码，能批量整理。
运行下面代码（建一个 0 文件夹 ，把原始表放进该文件夹，运行代码便可）

1. Sub rtian()
   
2.     fp = ThisWorkbook.Path
   
3.     fp = fp & "\0"
   
4.     mf = Dir(fp & "*.xls")
   
5.     Do While mf <> ""
   
6.         Workbooks.Open Filename:=(fp & mf)
   
7.         With ActiveWorkbook.Sheets(1)
   
8.             .Columns("c:c").Cut
   
9.             .Columns("a:a").Insert shift:=xlToRight
   
10.             .Columns("d:e").Cut
    
11.             .Columns("j").Insert shift:=xlToRight
    
12.             .Columns("e:e").Cut
    
13.             .Columns("g:g").Insert shift:=xlToRight
    
14.             .Range("a1") = "承包方代表姓名"
    
15.             .Range("h1") = "合同面积"
    
16.             With .Sort
    
17.                 .SortFields.Clear
    
18.                 .SortFields.Add Key:=[a1], Order:=xlDescending
    
19.                 .SetRange Range("a1").CurrentRegion
    
20.                 .Header = xlYes
    
21.                 .Apply
    
22.             End With
    
23.         End With
    
24.         ActiveWorkbook.Save
    
25.         ActiveWorkbook.Close
    
26.         mf = Dir
    
27.     Loop
    
28. End Sub

复制代码

可以得到下面的样子
现在求高手赐继续优化代码，能继续整理成下面表格的样子（最终整理后的表格 姓名排序无所谓）默认原始表有很多，最好能和上面的代码一样，把需要整理的表放到0文件夹，然后直接运行代码，可以一键整理。


下面的代码，合并单元格  时候有可能用到，代码有一点点毛病。

1. Sub test1()
   
2. Dim Arr, Arr_val(9999), MyRow, k
   
3. j = 1
   
4. MyRow = Sheet1.[E65535].End(3).Row
   
5. Arr = Sheet1.Range("a1:l" & MyRow)
   
6. '读非空行数
   
7. For i = 2 To MyRow
   
8.     If Arr(i, 1) <> "" Then
   
9.         Arr_val(j) = i
   
10.         j = j + 1
    
11.     End If
    
12. Next i
    
13. '选择行数合并
    
14. '
    
15. For k = 1 To MyRow
    
16. Range("A" & Arr_val(k) & ":" & "A" & Arr_val(k + 1) - 1).Select
    
17. Selection.Merge
    
18. Range("B" & Arr_val(k) & ":" & "B" & Arr_val(k + 1) - 1).Select
    
19. Selection.Merge
    
20. Next k
    
21. 
    
22. End Sub
    

复制代码

muyang45

哥，你附件没发上来啊！！！

rtian

功能代码给你整理出来了，你整合到你的文件里面吧

mencius372

muyang45 发表于 2016-5-29 19:57
哥，你附件没发上来啊！！！

忘记了，不好意思。补上来了。

mencius372

rtian 发表于 2016-5-29 20:47
功能代码给你整理出来了，你整合到你的文件里面吧

您好，老师！能实现我把需要整理的文件 放在 0 文件夹，从而一键整理吗。
就像您以前的代码一样！

mencius372

各位老师，谁能实现批量整理功能。
默认我的文件夹里有很多原始表

917067811

mencius372 发表于 2016-5-30 15:22
各位老师，谁能实现批量整理功能。
默认我的文件夹里有很多原始表

1. Option Explicit
   
2. '1.用户可以任意选择文件夹进行遍历
   
3. ' 2.限定遍历时仅搜索EXCEL文件（你可以改变文件类型）
   
4. '这个程序要先在“引用”下选择"microsoft scripting runtime"库文件
   
5. Dim ArryFile() As String
   
6. Dim nFile As Integer
   
7. 
   
8. Sub Filelist()
   
9.     Dim fso As New FileSystemObject
   
10.     Dim fd As Folder
    
11.     Dim strFilePath As String
    
12.     Dim FolderSelect As FileDialog
    
13.     Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
    
14.     With FolderSelect
    
15.         If .Show = -1 Then
    
16.             strFilePath = .SelectedItems.Item(1) & ""
    
17.         End If
    
18.     End With
    
19.     Set fd = fso.GetFolder(strFilePath)
    
20.     nFile = 0
    
21.     searchFile fd
    
22.     Sheets(1).Range("a1").Resize(nFile) = Application.Transpose(ArryFile)
    
23. End Sub
    
24. Private Function searchFile(ByVal fd As Folder)
    
25.     Dim fl As File
    
26.     Dim subfd As Folder
    
27.     Dim i As Integer
    
28.     On Error Resume Next
    
29.    
    
30.     i = fd.Files.Count
    
31.          
    
32.     ReDim Preserve ArryFile(1 To nFile + i)
    
33.     For Each fl In fd.Files
    
34.         If Right(fl.Name, 4) = "xls" Then
    
35.             nFile = nFile + 1
    
36.             ArryFile(nFile) = fl.path
    
37.         End If
    
38.     Next
    
39.     If fd.SubFolders.Count = 0 Then Exit Function
    
40.     For Each subfd In fd.SubFolders
    
41.         searchFile subfd
    
42.     Next
    
43. End Function

复制代码

917067811

917067811 发表于 2016-5-30 15:39

试试 遍历文件 在挨个打开 运行宏

mencius372

917067811 发表于 2016-5-30 15:39
试试 遍历文件 在挨个打开 运行宏

能详细说下嘛!您看下我的一楼的帖子。供测试的表格都在附件里。
您的代码我刚才没有运行成功。不好意思！

rtian

之前应该给你整理的有批量处理的代码。
帮你整理好了。。。。。。。。。