Excel-VBA常用技巧代码

多个工作薄合并成同一个工作薄，如何合并？
多人填一个同样的工作薄，形成了多个工作薄。

如何让几人填了一部分的工作薄合并成终稿。

Sub 汇总()
Dim mypath As String, myname As String, Dname As String, sh As Workbook, copyrow As Integer
Set sh = ThisWorkbook
mypath = ThisWorkbook.Path
myname =
Dname = Dir(mypath & "\*.xls")
Application.ScreenUpdating = False
Do While Dname <> ""
If Dname <> myname Then
copyrow = 1
With GetObject(mypath & "\" & Dname)
For i = 1 To .Worksheets.Count
If .Sheets(i).Cells(5, 3) <> "" Then
.Sheets(i).Rows("1:"
& .Sheets(i).UsedRange.Rows.Count).Copy sh.Sheets(i).Cells(copyrow, 1)
End If
Next
.Close False
End With
End If
Dname = Dir
Loop
Application.ScreenUpdating = True
MsgBox "OK!"
End Sub
合并工作簿：将其他工作簿的全部表合并到本工作
Sub 合并工作簿()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
Sheets().Move After:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Sub 合并工作表()
For Each st In Worksheets
If <> Then edRange.Offset(1, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next
End Sub
Sub 删除其他工作表()
Dim arr()
A =
icount = Sheets.Count
For i = 1 To icount
t = Sheets(i).Name
If t <> A Then
r = r + 1
ReDim Preserve arr(1 To r)
arr(r) = t
End If
Next
Sheets(arr).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End Sub
Sub 清空本表()
Cells.Select
Selection.ClearContents
Range("A1").Select
End Sub
Sub 导出()
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\Documents and Settings\y\桌面"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\y\桌面\新表.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Range("G4").Select
Application.DisplayAlerts = 0
Application.Quit
End Sub
将文件夹内的工作薄的sheet1的内容合并到当前工作薄
Sub test()
Dim w As Workbook, sh As Worksheet, MyPath As String, MyName As String Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
d() = ""
Next
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
Do While MyName <> ""
If MyName <> Then
With ThisWorkbook
Set w = CreateObject(.Path & "\" & MyName)
For Each sh In w.Worksheets
If d.Exists() Then _
edRange.Offset(1).Copy .Worksheets().[a65536].End(3)(2, 1) Next
Windows().Visible = True
w.Close False
End With
End If
MyName = Dir
Loop
Set d = Nothing
Set w = Nothing
ActiveWorkbook.RemovePersonalInformation = False
Application.ScreenUpdating = True
MsgBox "数据处理完毕。

" End Sub。