excel函数公式

将多个文件合并到一个工作簿

Sub Com()

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\" & "*.xls")

AWbName =

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)

Num = Num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To Wb.Sheets.Count

Wb.Sheets(G).UsedRange.Copy .Cells(.R ange("A65536").End(xlUp).Row + 1, 1)

Next

WbN = WbN & Chr(13) &

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("A1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示" End Sub 将工作簿拆分为多个文件

Private Sub 分拆工作表()

Dim sht As Worksheet

Dim MyBook As Workbook

Set MyBook = ActiveWorkbook

For Each sht In MyBook.Sheets

sht.Copy

ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & , FileFormat:=xlNormal '将工作簿另存为EXCEL 默认格式

ActiveWorkbook.Close

Next

MsgBox "文件已经被分拆完毕!"

End Sub

合并文件到不同工作表

Sub 工作薄间工作表合并()

Dim FileOpen

Dim X As Integer

Application.ScreenUpdating = False

FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel 文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄") X = 1

While X <= UBound(FileOpen)

Workbooks.Open Filename:=FileOpen(X)

Sheets().Move

After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) X = X + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

errhadler:

MsgBox Err.Description

End Sub 合并多个工作表到一个工作表

Sub 合并当前工作簿下的所有工作表()

Application.ScreenUpdating = False

For j = 1 To Sheets.Count

If Sheets(j).Name <> Then

X = Range("A65536").End(xlUp).Row + 1

Sheets(j).UsedRange.Copy Cells(X, 1)

End If

Next

Range("B1").Select

Application.ScreenUpdating = True

MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"

End Sub

将多个文件合并到一个工作簿（2）

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&

Set sh = ActiveSheet

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Cells.ClearContents

Do While MyName <> ""

If MyName <> Then

With GetObject(MyPath & MyName)

For Each sht In .Sheets

If IsSheetEmpty = IsEmpty(edRange) Then

m = m + 1

If m = 1 Then

sht.[a1].CurrentRegion.Copy sh.[a1]

Else

sht.[a1].CurrentRegion.Offset(1).Copy

sh.[a65536].End(xlUp).Offset(1)

End If

End If

Next

.Close False

End With

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

End Sub 返回A1：A10区域的最后一个非空单元格内容

=LOOKUP(1,0/(A1:A10<>""),A1:A10)

破解受保护工作表密码

Public Sub AllInternalPasswords()

' Breaks worksheet and workbook structure

modified for coverage

' of workbook structure / windows passwords and

for multiple passwords

'

(Version 1.1)

constants, and

passwords

Const DBLSPACE As String = vbNewLine & vbNewLine

Const AUTHORS As String = DBLSPACE & vbNewLine & _