用excel做一个工作簿如何做

1.如何将EXCEl多个工作簿复制到一个工作簿中

Sub 各表汇总（）

Dim fs, f, f1, fc, s, x, rowss, columnss

Dim filename, str As String

Set a = ActiveWorkbook

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(0， "选择文件夹"， 0, 0)

If Not objFolder Is Nothing Then

str = objFolder.self.path

Else: End

End If

Set objFolder = Nothing

Set objShell = Nothing '释放内存

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFolder(str)

Set fc = f.Files

x = 1

For Each f1 In fc

Application.ScreenUpdating = False

If Right(f1.Name, 3) = "xls" Then

Workbooks.Open (f1.path)

rowss = Workbooks(f1.Name).Sheets(1).Range("A65536").End(xlUp).Row

columnss = Workbooks(f1.Name).Sheets(1).Columns.Count

Application.CutCopyMode = True

Workbooks(f1.Name).Sheets(1).Range("a2" & ":y" & CStr(rowss)).Copy

a.Activate

'MsgBox ActiveWorkbook.Name

ActiveSheet.Range("b" & CStr(x + 1) & ":z" & CStr(x + rowss - 1)).Select

ActiveSheet.Paste

i = Workbooks(f1.Name).Name

j = Left(i, Len(i) - 4)

a.Sheets(1).Range("a" & CStr(x + 1) & ":a" & CStr(x + rowss - 1)) = j

x = x + rowss - 1

Application.CutCopyMode = False

Workbooks(f1.Name).Close savechanges:=False

End If

Next

Application.ScreenUpdating = ture

Set fc = Nothing

Set f = Nothing

Set fs = Nothing '释放内存

End Sub