[已解决]想来挑战下吗，试下这个题吧

hoogle

第一个运行时间小于30S的为最佳，因为原始数据有很多。
VBA求助，多工作薄重新组合1.rar (355.76 KB, 下载次数: 43)

2013-1-5 22:26 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

青城山苦丁茶

2013-1-6 16:19

试试看。
Sub test()
Dim ar()
f_p1$ = "e:\tmp\"   '源文件位置
f_p2$ = "e:\tmp\t\" '目标文件位置
f_n$ = Dir(f_p1 & "*.xls*")
Application.ScreenUpdating = 0
ReDim ar(1 To 5)
Do While f_n <> ""
i = i% + 1
If i > UBound(ar) Then ReDim Preserve ar(1 To i + 5)
ar(i) = f_n
f_n$ = Dir
Loop
For i2% = 1 To i
   Set wk = Workbooks.Open(f_p1 & ar(i2))
   For Each sht In wk.Sheets
       If Dir(f_p2 & sht.Name & ".xlsx") = "" Then
         sht.Copy
         i3% = 4
         If Right(ar(i2), 1) = "x" Then i3 = 5
         ActiveSheet.Name = Left(ar(i2), Len(ar(i2)) - i3)
         ActiveWorkbook.SaveAs Filename:=f_p2 & sht.Name & ".xlsx"
         ActiveWorkbook.Close
       Else
         Set wk2 = Workbooks.Open(f_p2 & sht.Name & ".xlsx")
         Set sht2 = wk2.Worksheets.Add(, wk2.Sheets(wk2.Sheets.Count))
         i3% = 4
         If Right(ar(i2), 1) = "x" Then i3 = 5
         sht2.Name = Left(ar(i2), Len(ar(i2)) - i3)
         sht.Cells.Copy sht2.[a1]
         wk2.Save
         wk2.Close
         Set wk2 = Nothing
         Set sht2 = Nothing
       End If
   Next
   wk.Close
Next
End Sub
就是一些打开关闭打开关闭

跳转到最佳答案楼层

zhoucs00

2、新合并的工作薄里同样包含10张表，分别是这些人对评价的这个人的评价，然后命名为被评价人.xls。 不懂啥意思，能模拟个结果就好了。留个脚印。。。

hoogle

zhoucs00 发表于 2013-1-6 09:37
2、新合并的工作薄里同样包含10张表，分别是这些人对评价的这个人的评价，然后命名为被评价人.xls。 不懂啥 ...

附件图片是模拟结果。

青城山苦丁茶

试试看。
Sub test()
Dim ar()
f_p1$ = "e:\tmp\"   '源文件位置
f_p2$ = "e:\tmp\t\" '目标文件位置
f_n$ = Dir(f_p1 & "*.xls*")
Application.ScreenUpdating = 0
ReDim ar(1 To 5)
Do While f_n <> ""
i = i% + 1
If i > UBound(ar) Then ReDim Preserve ar(1 To i + 5)
ar(i) = f_n
f_n$ = Dir
Loop
For i2% = 1 To i
   Set wk = Workbooks.Open(f_p1 & ar(i2))
   For Each sht In wk.Sheets
       If Dir(f_p2 & sht.Name & ".xlsx") = "" Then
         sht.Copy
         i3% = 4
         If Right(ar(i2), 1) = "x" Then i3 = 5
         ActiveSheet.Name = Left(ar(i2), Len(ar(i2)) - i3)
         ActiveWorkbook.SaveAs Filename:=f_p2 & sht.Name & ".xlsx"
         ActiveWorkbook.Close
       Else
         Set wk2 = Workbooks.Open(f_p2 & sht.Name & ".xlsx")
         Set sht2 = wk2.Worksheets.Add(, wk2.Sheets(wk2.Sheets.Count))
         i3% = 4
         If Right(ar(i2), 1) = "x" Then i3 = 5
         sht2.Name = Left(ar(i2), Len(ar(i2)) - i3)
         sht.Cells.Copy sht2.[a1]
         wk2.Save
         wk2.Close
         Set wk2 = Nothing
         Set sht2 = Nothing
       End If
   Next
   wk.Close
Next
End Sub
就是一些打开关闭打开关闭