Sub 選擇檔案()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
With Sheets("總表")
If .FilterMode Then .ShowAllData
.Range("a2:j" & .[a65536].End(3).Row) = ""
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "D:\"
.AllowMultiSelect = True
.Show
fc = .SelectedItems.Count
If fc = 0 Then Exit Sub
Tm = Timer
For x = 1 To fc
FPath = .SelectedItems(x)
Set WB = Workbooks.Open(FPath)
With Sheets(1)
If .FilterMode Then .ShowAllData
Arr = .Range("a3:i" & .[a65536].End(3).Row)
fn = Split(ActiveWorkbook.Name, ".")(0)
End With
WB.Close
n = [a65536].End(xlUp).Row + 1
Range("a" & n).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
Range("j" & n & ":j" & [a65536].End(xlUp).Row) = fn
Next
End With
End With
Sub 選擇檔案()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
With Sheets("總表")
If .FilterMode Then .ShowAllData '有篩選時解除篩選
.Range("a2:j" & .[a65536].End(3).Row) = "" '清除資料
With Application.FileDialog(msoFileDialogOpen) '選擇需求檔案
.InitialFileName = "D:\" '預設D槽
.AllowMultiSelect = True '可複選
.Show '畫面顯示
fc = .SelectedItems.Count '計算選擇檔案數
If fc = 0 Then Exit Sub '沒選檔案則離開
Tm = Timer '開始計時
For x = 1 To fc
FPath = .SelectedItems(x) '檔案路徑
Set WB = Workbooks.Open(FPath) '開啟檔案
With Sheets(1) '檔案的第1 sheet
If .FilterMode Then .ShowAllData '有篩選時解除篩選
Arr = .Range("a3:i" & .[a65536].End(3).Row) '來源裝入數組
fn = Split(ActiveWorkbook.Name, ".")(0) '取得檔名
End With
WB.Close '關閉來源檔案
n = [a65536].End(xlUp).Row + 1 '總表a欄最後一筆資料+1的位置
Range("a" & n).Resize(UBound(Arr), UBound(Arr, 2)) = Arr '來源貼入總表
Range("j" & n & ":j" & [a65536].End(xlUp).Row) = fn '來源的檔名貼入總表
Next
End With
End With
Sub test2()
Dim Arr, WB, fc%, x%, fn$, n%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
n = 1
With Sheets("總表")
If .FilterMode Then .ShowAllData
.Range("a1:AA" & .[a65536].End(3).Row).Delete
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "D:\"
.AllowMultiSelect = True
.Show
fc = .SelectedItems.Count
If fc = 0 Then Exit Sub
Tm = Timer
For x = 1 To fc
FPath = .SelectedItems(x)
Set WB = Workbooks.Open(FPath)
With Sheets(1)
If .FilterMode Then .ShowAllData
fn = Split(ActiveWorkbook.Name, ".")(0)
.Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("總表").Range("a" & n)
End With
WB.Close
Range("AA" & n & ":AA" & [a65536].End(xlUp).Row) = fn
n = [a65536].End(xlUp).Row + 1
Next
End With
End With
Private Sub UserForm_Activate()
Dim fs, f, fc, xD, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set xD = CreateObject("Scripting.Dictionary")
'a = ThisWorkbook.Path '程式檔與資料檔放同一個資料夾
a = "D:\test" '資料檔放在固定路徑
fnorg = ActiveWorkbook.Name
Set f = fs.GetFolder(a)
Set fc = f.Files
For Each f1 In fc
n = n + 1
If InStr(f1.Path, fnorg) Then GoTo 99
Arr(n, 1) = f1.Path
Arr(n, 2) = Split(f1.Name, ".")(0)
xD(Arr(n, 2) & "") = ""
99: Next
Me.ListBox1.List = xD.keys
Set fs = Nothing: Set f = Nothing: Set fc = Nothing: Set xD = Nothing
EndSub:
End Sub作者: wang077 時間: 2021-7-7 09:03
回復 44#samwang
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
For i1 = 1 To n1
If Not xD.Exists(Ar(i1, 1) & "") Then
xD(Ar(i1, 1) & "") = ""
For i = 1 To n
If Arr(i, 2) = Ar(i1, 1) Then n2 = n2 + 1: Ar1(n2, 1) = Arr(i, 1)
Next
End If
Next
R = 1: Sheets("6月份數據").Select
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
.Range("a1:AA" & .[a65536].End(3).Row).Delete
Tm = Timer
For i1 = 1 To n2
Set WB = Workbooks.Open(Ar1(i1, 1))
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
fn = Split(ActiveWorkbook.Name, ".")(0)
.Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("6月份數據").Range("a" & R)
End With
WB.Close
.Range("U" & R & ":U" & .[a65536].End(xlUp).Row) = fn
R = .[a65536].End(xlUp).Row + 1
Next
End With
MsgBox "資料複製完成" & Timer - Tm & "秒"
Erase Arr: Erase Ar
Unload Me
回復 44#samwang
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
fileorg = ActiveWorkbook.Name
Set xD = CreateObject("Scripting.Dictionary")
For i1 = 1 To n1
If Not xD.Exists(Ar(i1, 1) & "") Then
xD(Ar(i1, 1) & "") = ""
For i = 1 To n
If Arr(i, 2) = Ar(i1, 1) Then n2 = n2 + 1: Ar1(n2, 1) = Arr(i, 1)
Next
End If
Next
R = 1: Sheets("6月份數據").Select
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
.Range("a1:AA" & .[a65536].End(3).Row).Delete
Tm = Timer
For i1 = 1 To n2
Set WB = Workbooks.Open(Ar1(i1, 1))
With Sheets("6月份數據")
If .FilterMode Then .ShowAllData
fn = Split(ActiveWorkbook.Name, ".")(0)
.Range("a1:z" & .[a65536].End(3).Row).Copy Workbooks(fileorg).Sheets("6月份數據").Range("a" & R)
End With
WB.Close
.Range("U" & R & ":U" & .[a65536].End(xlUp).Row) = fn
R = .[a65536].End(xlUp).Row + 1
Next
End With
MsgBox "資料複製完成" & Timer - Tm & "秒"
Erase Arr: Erase Ar
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
Private Sub CommandButton5_Click()
Dim ar2, s%
s = 0: ReDim ar2(s)
With Sheets("總表").Range("a2:u" & [a65536].End(3).Row)
Sheets(1).AutoFilterMode = False
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
ReDim Preserve ar2(s)
ar2(s) = CStr(ListBox2.List(i))
s = s + 1
End If
Next
.AutoFilter Field:=7, Criteria1:=ar2, Operator:=xlFilterValues
End With
Set ar2 = Nothing
End Sub作者: wang077 時間: 2021-7-12 07:57
