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

rouber590324

DEAR ALL 大大
1.如下程式碼為前輩針對指定資料夾ALL-EXCEL自動彙整至總表方式(多工作表)-工作表名稱相同-空白工作表不予COPY
2.請教前題是  每一  EXCEL 之格式都相同  如何指定資料夾ALL-EXCEL自動彙整至總表方式(單一EXCEL)-工作表名稱相同-空白工作表不予COPY
  2.1 就是  資料夾 ALL EXCEL 內之  SHEETS 之格式都相同.要將資料彙整同一 EXCEL 之同一 SHEETS (建立資料庫總表)
  2.2 煩不吝賜教   THANKS*10000   

Sub yy()
  Dim a As Workbook, f$
  Dim p$, sh As Worksheet
  Set a = ThisWorkbook
  p = "C:\AAA\"
  f = Dir(p & "*.xls")
  Application.ScreenUpdating = False
  Do While f <> ""
    Workbooks.Open p & f
    For Each sh In Worksheets
    X = WorksheetFunction.CountA(sh.Range("a1:iv65536"))
    Y = ActiveWorkbook.Name
    If X <> 0 Then
      sh.Copy after:=a.Sheets(a.Sheets.Count)
    End If
    Next
    Windows(f).Close True
    f = Dir
  Loop
  Application.ScreenUpdating = True
  Sheet1.Select
  Range("A1").Select
End Sub

GBKEE

回復 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

複製代碼

rouber590324

DEAR  GBKEE 大大
  非常非常感謝您之指導-100%符合需求  THANKS*10000