Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2314|回复: 3

[已解决]合并文件夹下的所有excel中某个工作簿的内容

[复制链接]
发表于 2015-9-18 13:57 | 显示全部楼层 |阅读模式
我需要把多个excel中的“25.用户接入点”这个工作簿整合到一个excel中,希望各位大神能帮忙写个代码!!谢谢大家!!
最佳答案
2015-9-21 10:35
请看附件。

合并.rar

96.99 KB, 下载次数: 10

 楼主| 发表于 2015-9-19 16:09 | 显示全部楼层
有那个大神能帮帮忙,万分感谢啊!!!
回复

使用道具 举报

发表于 2015-9-21 10:35 | 显示全部楼层
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim Filename, wb As Workbook, Sht As Worksheet
  4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
  5.     On Error GoTo aa
  6.     Dim brr(1 To 10000, 1 To 30)
  7.     Do While Filename <> ""
  8.         If Filename <> ThisWorkbook.Name Then
  9.             fn = ThisWorkbook.Path & "" & Filename
  10.             Set wb = Workbooks.Open(fn)
  11.             Set Sht = wb.Worksheets("25.用户接入点")
  12.             arr = Sht.Range("a5:u" & Sht.[c65536].End(3).Row)
  13.             wb.Close False
  14.             For i = 1 To UBound(arr)
  15.                 If Len(arr(i, 3)) > 0 Then
  16.                     n = n + 1
  17.                     brr(n, 1) = n
  18.                     For j = 2 To UBound(arr, 2)
  19.                         brr(n, j) = arr(i, j)
  20.                     Next
  21.                 End If
  22.             Next
  23.         End If
  24. aa:
  25.         Filename = Dir
  26.     Loop
  27.     Set Sht = Nothing
  28.     If n > 0 Then
  29.         [a5:u10000].ClearContents
  30.         [a5].Resize(n, UBound(arr, 2)) = brr
  31.     End If
  32.     Application.ScreenUpdating = True
  33. End Sub
复制代码
回复

使用道具 举报

发表于 2015-9-21 10:35 | 显示全部楼层    本楼为最佳答案   
请看附件。

合并.rar

121.96 KB, 下载次数: 10

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 09:38 , Processed in 0.400965 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表