返回列表 上一主題 發帖

[發問] 資料夾內ALL EXCEL 彙整方式請教

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2015-3-17 07:58 | 顯示全部帖子
回復 1# rouber590324
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim P As String, F As String, Rng As Range, Sh As Worksheet, Sh_Name As String
  4.     P = "C:\AAA\"
  5.     F = Dir(P & "*.xls")
  6.     If F = "" Then Exit Sub
  7.     Sh_Name = ","
  8.     Set Rng = Workbooks.Add(1).Sheets(1).[A1]  '新增活頁簿(一張工作表): 設置目的儲存格
  9.     Application.ScreenUpdating = False
  10.     Do While F <> ""
  11.         With Workbooks.Open(P & F)
  12.             For Each Sh In .Worksheets
  13.                 '工作表名稱相同 (或) 空白工作表,不予COPY
  14.                 If InStr(Sh_Name, "," & Sh.Name & ",") = 0 Then '工作表名稱不相同
  15.                     Sh_Name = Sh_Name & Sh.Name & ","           '新增工作表名稱
  16.                     If WorksheetFunction.CountA(Sh.UsedRange.Columns(1)) > 0 Then '不是空白工作表
  17.                         Sh.UsedRange.Copy Rng  '資料複製到目的儲存格
  18.                         '目的儲存格重置******
  19.                         If Rng.End(xlDown).Row = Rows.Count Then
  20.                             Set Rng = Rng.Offset(1)             '下移一列
  21.                         Else
  22.                             Set Rng = Rng.End(xlDown).Offset(1)  '下移到最後有資料的一列
  23.                         End If
  24.                         '*********************
  25.                     End If
  26.                 End If
  27.             Next
  28.             .Close False
  29.         End With
  30.         F = Dir
  31.     Loop
  32.     Rng.Parent.SaveAs "D:\資料庫.XLS" '資料彙整同一 EXCEL後存檔
  33.     Application.ScreenUpdating = True
  34. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 信心、毅力、勇氣三者具備，則天下沒有做不成的事。
返回列表 上一主題