推 JieJuen:未測試先推 02/17 21:21
※ 引述《ileasa (清純低假高中妹)》之銘言：
: (若是和其他不同軟體互動之問題 請記得一併填寫)
: 您所使用的軟體為:office excel
: 版本: 2003
: 問題:如果有20個excel的檔案
: 然而要在一個新的excel的檔案裡
: 把那20個檔案裡面的其中同一列都複製到新的檔案裡面
: 應該如何做呢?
: 我目前是用最笨的方法就是一個一個檔案開啟來
: 然後複製之後在到新檔案貼上
: 不過做好一天份的檔案要花一個小時
: 我總共要做三個月份的
: 可以告訴我比較快的方法嗎?
: 謝謝!!
之前幫同事寫的程式...
目的是為了合併同一個資料夾下面的所有Excel檔成一個
1.開啟Excel檔
2.點選[工具]→[巨集]→[Visual Basic 編輯器]開啟VBA編輯器(VBE)
3.在VBE中：
a.點選[插入]→[模組]
b.點選[工具]→[設定引用項目]，勾選[Microsoft Scripting Runtime]
4.將下面的程式碼貼在右邊：
==============================================================================
Sub MergeXlsFiles()
Dim myFSO As Scripting.FileSystemObject
Dim myFiles As Scripting.Files
Dim myFile As Scripting.File
Dim filename As String
Dim newfilename As String
Dim newWB As Workbook
Dim currWB As Workbook
Dim myName As Name
Dim i As Integer
Set currWB = ThisWorkbook
Set myFSO = New Scripting.FileSystemObject
newfilename=Mid(currWB.Path,Len(myFSO.GetParentFolderName(currWB.Path))+2)
newfilename = currWB.Path & "\" & InputBox("請輸入檔案名稱",,newfilename)
If (Right(newfilename, 3) <> "xls") Then
newfilename = newfilename & ".xls"
End If
Set newWB = Workbooks.Add
newWB.SaveAs newfilename
Set myFiles = myFSO.GetFolder(ThisWorkbook.Path).Files
For Each myFile In myFiles
If (myFile.Type = "Microsoft Excel 工作表" And _
myFile.Name <> currWB.Name And newWB.Name <> myFile.Name) Then
filename = myFile.Name
Workbooks.Open currWB.Path & "\" & filename, ReadOnly:=True
Workbooks(filename).Worksheets.Copy _
After:=newWB.Worksheets(newWB.Worksheets.Count)
Workbooks(filename).Close savechanges:=False
End If
Next
Application.DisplayAlerts = False
For i = Application.SheetsInNewWorkbook To 1 Step -1
newWB.Worksheets(i).Delete
Next
Application.DisplayAlerts = True
For Each myName In newWB.Names
myName.Delete
Next
newWB.Close savechanges:=True
currWB.Close savechanges:=False
Set newWB = Nothing
Set currWB = Nothing
Set myFile = Nothing
Set myFiles = Nothing
Set myFSO = Nothing
End Sub
============================================================================
這樣就會把所有檔案合併成一個Excel檔^^"
--
跟妳的要求是有差啦....^^"
不過...沒詳細資料我也沒得寫...﹨(╯▽╰)∕
--
沒事多灌水...
多灌水沒事...
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 221.169.7.130